text:
 Psychological Resource Associates

Psychological Resource Associates (PRA) is a multidisciplinary group of 13 independent Counseling and Psychological Services psychotherapists in Davis and Woodland with a wide range of expertise and interests. They offer consultation for couple, family and child problems. Specific areas of interest include: life transitions, stress management, eating disorders, human trauma, mens and womens issues.

Dr. Dean Dickerson is a trained EMDR specialist. EMDR or Adaptive Information Processing is an integration of therapeutic approaches that provides rapid resolution of PTSD.

EMDR is effective with:

 Post traumatic stress disorders
 Performance enhancement
 Generalized Anxiety, Panic Attacks
 Depression
 Attachment Disorders
 Simple and Process Phobias
 Addiction

Services:

 Currently accepting new referrals
 Supervision groups for Level I and Level II EMDR trained therapists
 Individual case consultation to therapists on single event or complex trauma
 Supervision for therapists wishing to be certified by the International Association.
 Presentations to groups or facilities on EMDR

Susan Dickerson, LCSW  Brief therapy for life transitions, grief and loss, stress management, relationship issues, communication skills, and women’s issues. She works with adults and couples.

Judith Blum, MFT  Individuals and families in transition, the impact of grief and loss, stress management, and coping skills for emotional wellbeing. She has extensive experience working with school age children and their families, including blended families. She has specialized training working with ADD related issues in both children and adults.

Tina Dolin, LCSW  Certified alcohol and drug abuse counselor. Tina is also a certified SAP (Substance Abuse Professional). In addition to working with clients with substance abuse issues, she works with individuals, couples and families coping with depression, anxiety, abuse, trauma, parenting and divorce issues.

Judy Feldman, LCSW   Special interest in the development of self, relationship issues, life transitions, separation and divorce, stress management, grief and loss, and issues related to health and wellbeing. She works with adults and adolescents and sees individuals, couples and families.

Marta Induni, MFT  Bilingual (Spanish) and bicultural. Currently provides individual, couples and family therapy. Professional interests include life transitions, stress management, mood disorders and people affected by chronic physical ailments.

Myles Montgomery, LCSW  Experience working in the fields of education, public child welfare, and communitybased service. He is currently a clinical social worker and therapist at EMQFamiliesFirst. Myles provides brief and interpersonal therapy with a focus on building consensus and constructing solutions.

Janet Oleson, LCSW  Works primarily with adults dealing with issues such as depression, anxiety, chronic illness and/or substance abuse. Special interests include early adulthood and midlife transitions with an integrated approach to include bio/psycho/spiritual/social aspects.

Rory Osborne, Ph.D.   Background in trauma and critical incident response on both an individual and an organizational level. He currently provides individual, couples, and family therapy. Professional interests include life transitions, trauma, and organizational development.

Janet Perkins, MFT  More than ten years experience providing child, adolescent, and family therapy in DavisWoodland school, outpatient, and residential settings. She is currently a therapist and clinical coordinator at EMQFamiliesFirst. Her work focuses on helping clients to increase personal fulfillment, as well as the quality of their family relationships.

Kevin Wheeler, LCSW  Has worked as a social worker since 1987 as a school counselor in a middle school, a homebased mental health service provider, and as clinical director and therapist for a residential treatment program for latency age and adolescent boys and their families. He is currently a clinical social worker at UC Davis Medical Center. His emphasis is supporting families to create their own solutions and to realize their dreams.

Rosemary Miles. Ph.D., MFT  Rosemary works primarily with EMDR Therapy for trauma, anxiety/mood disorders, grief and loss, and pain management issues. She is also a skilled Emotion Focused Couple Therapist and can help you recreate a safe and vibrant relationship with your partner.

Neil Robinson, MFT   Neil specializes in working with younger people from the ages of five to eighteen years old who suffer from acute and chronic issues of depression, anxiety, anger, trauma, addiction, relationship issues, fear and social withdrawal. He also provides counseling services for men, women, couples, and families who suffer from issues of anxiety, depression, addiction, relationship, sexual identity issues and trauma.

Luis Gonzalez, MFT Intern  Luis is a MFT intern close to his licensing exam. Luis works with couples and individual clients seeking breakthroughs with depression, posttraumatic stress, life transitions, grief and loss, and spirituality.  Luis also helps couples prepare for marriage, or enhance their current relationship by using the Prepare/Enrich Assessment Program.

Danae Azevedo, Office Manager/Intake Coordinator  One of the unique and valuable aspects of PRA is that each person who calls receives personal assistance in finding an appropriate therapist. I am a third year graduate student pursuing a degree in Counseling Psychology from Sacramento State and I am responsible for matching clients with the therapist best suited to their needs. I then follow up the intake to ensure that each client is seen in a timely fashion.

Psychological Resource Associates currently offers Employee Assistance Programs to the following agencies and businesses.

Yolo County  1652 employees. 6 visits per employee each fiscal year.
Yolo County Office of Education 177 employees. 8 visits per employee with $10 copay after 1st session.
Davis Joint Unified School District  340 employees. 5 visits per employee and 5 visits for 1 additional family member each year.

Davis Family Therapy Collaborative has teamed up with PRA specializing in family therapy and utilizing a shortterm design that focuses on solutions, not problems. Their combined experience of over 25 years working with highconflict families is the foundation of their service.

In six to eight sessions, families receive:

	Strengthbased inventory of the parents’ skill set which, along with other family strengths, becomes the basis for mutual goal setting
	Full partnership with both parent and child to support the family’s ability to develop and implement solutions
	Positive behavior training

Their mission is to provide the best therapeutic skills and interventions to assist each family.
Therapists Myles Montomery, Kevin Wheeler and Janet Perkins can be contacted through Psychological Resource Associates for more information.

 Davis offers a wide variety of Counseling and Psychological Services.


text:
      MODULE ttutil
      INTERFACE
         FUNCTION lint (Table, iltab, x)
         REAL                               :: lint
         INTEGER, INTENT(IN)                :: iltab
         REAL, DIMENSION(iltab), INTENT(IN) :: Table
         REAL, INTENT(IN)                   :: x
         END FUNCTION lint
      END INTERFACE
      END MODULE ttutil

max_issues_repo_name: zhumiansanren/FIRI-WHS


function distance(i) result(j)
    REAL, intent(in) :: i ! input
    integer :: j ! output

    INTEGER :: num
    INTEGER :: offset

    num = FLOOR(REAL(CEILING(SQRT(i))) / 2)
    offset = MOD(INT(i - ((2 * num - 1) ** 2)), 2 * num)

    j = num + ABS(offset - num)
 end function distance

 program one
    integer :: distance
    REAL :: n = 23
    print *, "distance of ", n, " is: ", distance(n)
 end program one


subroutine tomnsp(frcc, frss, fzcs, fzsc, flcs, flsc, &
                  armn, brmn, crmn, azmn, bzmn, czmn, blmn, clmn, arcon, azcon, &
                  work1, work2, work3)

      use stel_kinds, only: dp
      use name0, only: czero
      use name1, only: mpol1, nmax, nzeta, ntheta2
      use scalars, only: ns
      use extfld, only: ivac
      use mnarray, only: xmpq, jmin2, jlam
      use trignew, only: cosmui, sinmu, cosmumi, sinmum, &
                         cosnv,  sinnv, cosnvn,  sinnvn

      implicit none

      ! inout needed since the force vector gc is initialized to 0 outside (funct3d)
      real(kind=dp), intent(inout) :: frcc(ns,0:nmax,0:mpol1)
      real(kind=dp), intent(inout) :: frss(ns,0:nmax,0:mpol1)
      real(kind=dp), intent(inout) :: fzcs(ns,0:nmax,0:mpol1)
      real(kind=dp), intent(inout) :: fzsc(ns,0:nmax,0:mpol1)
      real(kind=dp), intent(inout) :: flcs(ns,0:nmax,0:mpol1)
      real(kind=dp), intent(inout) :: flsc(ns,0:nmax,0:mpol1)

      real(kind=dp), intent(in)    :: armn (ns*nzeta,ntheta2,0:1)
      real(kind=dp), intent(in)    :: brmn (ns*nzeta,ntheta2,0:1)
      real(kind=dp), intent(in)    :: crmn (ns*nzeta,ntheta2,0:1)
      real(kind=dp), intent(in)    :: azmn (ns*nzeta,ntheta2,0:1)
      real(kind=dp), intent(in)    :: bzmn (ns*nzeta,ntheta2,0:1)
      real(kind=dp), intent(in)    :: czmn (ns*nzeta,ntheta2,0:1)
      real(kind=dp), intent(in)    :: blmn (ns*nzeta,ntheta2,0:1)
      real(kind=dp), intent(in)    :: clmn (ns*nzeta,ntheta2,0:1)
      real(kind=dp), intent(in)    :: arcon(ns*nzeta,ntheta2,0:1)
      real(kind=dp), intent(in)    :: azcon(ns*nzeta,ntheta2,0:1)

      ! all these refer to the global "workb" array
      real(kind=dp), intent(inout) :: work1(ns*nzeta*12)
      real(kind=dp), intent(inout) :: work2(ns*nzeta,12)
      real(kind=dp), intent(inout) :: work3(ns,nzeta,12)

      integer       :: jmax, i, jk, k, l, m, n, js, mparity
      real(kind=dp) :: temp1, temp3

      ! include contribution from LCFS only in free-boundary mode
      jmax = ns
      if (ivac.lt.1) &
        jmax = ns-1

      ! BEGIN INVERSE FOURIER TRANSFORM
      ! DO THETA (U) INTEGRATION FIRST
      do m = 0, mpol1
        mparity = mod(m, 2)

        ! clean up workspace first
        do l = 1, 12*ns*nzeta
          work1(l) = czero
        end do

        do i = 1, ntheta2
          do jk = 1, ns*nzeta

            ! effective A forces on R and Z: MHD + Spectral Condensation
            temp1        =                armn(jk,i,mparity) + xmpq(m,1)*arcon(jk,i,mparity)
            temp3        =                azmn(jk,i,mparity) + xmpq(m,1)*azcon(jk,i,mparity)

            work2(jk, 1) = work2(jk, 1) + temp1             *cosmui (i,m) + brmn(jk,i,mparity)*sinmum (i,m)
            work2(jk, 2) = work2(jk, 2) - crmn(jk,i,mparity)*cosmui (i,m)
            work2(jk, 3) = work2(jk, 3) + temp1             *sinmu  (i,m) + brmn(jk,i,mparity)*cosmumi(i,m)
            work2(jk, 4) = work2(jk, 4) - crmn(jk,i,mparity)*sinmu  (i,m)
            work2(jk, 5) = work2(jk, 5) + temp3             *cosmui (i,m) + bzmn(jk,i,mparity)*sinmum (i,m)
            work2(jk, 6) = work2(jk, 6) - czmn(jk,i,mparity)*cosmui (i,m)
            work2(jk, 7) = work2(jk, 7) + temp3             *sinmu  (i,m) + bzmn(jk,i,mparity)*cosmumi(i,m)
            work2(jk, 8) = work2(jk, 8) - czmn(jk,i,mparity)*sinmu  (i,m)
            work2(jk, 9) = work2(jk, 9) + blmn(jk,i,mparity)*sinmum (i,m)
            work2(jk,10) = work2(jk,10) - clmn(jk,i,mparity)*cosmui (i,m)
            work2(jk,11) = work2(jk,11) + blmn(jk,i,mparity)*cosmumi(i,m)
            work2(jk,12) = work2(jk,12) - clmn(jk,i,mparity)*sinmu  (i,m)
          end do ! jk
        end do ! i

        ! NEXT, DO ZETA (V) INTEGRATION
        do n = 0, nmax

          ! ns*nzeta from first half of transform is split up here since
          ! R,Z forces are computed from jmin2(m) on and lambda forces from jlam(m) on
          ! --> for axis, inner most surface: forces only from restricted poloidal modes
          do k = 1, nzeta
            do js = jmin2(m), jmax
              frcc(js,n,m) = frcc(js,n,m) + work3(js,k, 1)*cosnv (k,n) &
                                          + work3(js,k, 2)*sinnvn(k,n)
              frss(js,n,m) = frss(js,n,m) + work3(js,k, 3)*sinnv (k,n) &
                                          + work3(js,k, 4)*cosnvn(k,n)
              fzcs(js,n,m) = fzcs(js,n,m) + work3(js,k, 5)*sinnv (k,n) &
                                          + work3(js,k, 6)*cosnvn(k,n)
              fzsc(js,n,m) = fzsc(js,n,m) + work3(js,k, 7)*cosnv (k,n) &
                                          + work3(js,k, 8)*sinnvn(k,n)
            end do ! js

            do js = jlam(m), ns
              flcs(js,n,m) = flcs(js,n,m) + work3(js,k, 9)*sinnv (k,n) &
                                          + work3(js,k,10)*cosnvn(k,n)
              flsc(js,n,m) = flsc(js,n,m) + work3(js,k,11)*cosnv (k,n) &
                                          + work3(js,k,12)*sinnvn(k,n)
            end do ! js
          end do ! k
        end do ! n

      end do ! m

      return
end


text:
! This file was automatically generated by SWIG (http://www.swig.org).
! Version 4.0.0
!
! Do not make changes to this file unless you know what you are doing--modify
! the SWIG interface file instead.

! ---------------------------------------------------------------
! Programmer(s): Auto-generated by swig.
! ---------------------------------------------------------------
! SUNDIALS Copyright Start
! Copyright (c) 2002-2022, Lawrence Livermore National Security
! and Southern Methodist University.
! All rights reserved.
!
! See the top-level LICENSE and NOTICE files for details.
!
! SPDX-License-Identifier: BSD-3-Clause
! SUNDIALS Copyright End
! ---------------------------------------------------------------

module farkode_mod
 use, intrinsic :: ISO_C_BINDING
 use fsundials_nvector_mod
 use fsundials_context_mod
 use fsundials_types_mod
 use fsundials_matrix_mod
 use fsundials_nvector_mod
 use fsundials_context_mod
 use fsundials_types_mod
 use fsundials_linearsolver_mod
 use fsundials_matrix_mod
 use fsundials_nvector_mod
 use fsundials_context_mod
 use fsundials_types_mod
 use fsundials_nonlinearsolver_mod
 use fsundials_types_mod
 implicit none
 private

 ! DECLARATION CONSTRUCTS
 integer(C_INT), parameter, public :: ARK_NORMAL = 1_C_INT
 integer(C_INT), parameter, public :: ARK_ONE_STEP = 2_C_INT
 integer(C_INT), parameter, public :: ARK_ADAPT_CUSTOM = -1_C_INT
 integer(C_INT), parameter, public :: ARK_ADAPT_PID = 0_C_INT
 integer(C_INT), parameter, public :: ARK_ADAPT_PI = 1_C_INT
 integer(C_INT), parameter, public :: ARK_ADAPT_I = 2_C_INT
 integer(C_INT), parameter, public :: ARK_ADAPT_EXP_GUS = 3_C_INT
 integer(C_INT), parameter, public :: ARK_ADAPT_IMP_GUS = 4_C_INT
 integer(C_INT), parameter, public :: ARK_ADAPT_IMEX_GUS = 5_C_INT
 integer(C_INT), parameter, public :: ARK_FULLRHS_START = 0_C_INT
 integer(C_INT), parameter, public :: ARK_FULLRHS_END = 1_C_INT
 integer(C_INT), parameter, public :: ARK_FULLRHS_OTHER = 2_C_INT
 integer(C_INT), parameter, public :: ARK_INTERP_MAX_DEGREE = 5_C_INT
 integer(C_INT), parameter, public :: ARK_INTERP_HERMITE = 0_C_INT
 integer(C_INT), parameter, public :: ARK_INTERP_LAGRANGE = 1_C_INT
 integer(C_INT), parameter, public :: ARK_SUCCESS = 0_C_INT
 integer(C_INT), parameter, public :: ARK_TSTOP_RETURN = 1_C_INT
 integer(C_INT), parameter, public :: ARK_ROOT_RETURN = 2_C_INT
 integer(C_INT), parameter, public :: ARK_WARNING = 99_C_INT
 integer(C_INT), parameter, public :: ARK_TOO_MUCH_WORK = -1_C_INT
 integer(C_INT), parameter, public :: ARK_TOO_MUCH_ACC = -2_C_INT
 integer(C_INT), parameter, public :: ARK_ERR_FAILURE = -3_C_INT
 integer(C_INT), parameter, public :: ARK_CONV_FAILURE = -4_C_INT
 integer(C_INT), parameter, public :: ARK_LINIT_FAIL = -5_C_INT
 integer(C_INT), parameter, public :: ARK_LSETUP_FAIL = -6_C_INT
 integer(C_INT), parameter, public :: ARK_LSOLVE_FAIL = -7_C_INT
 integer(C_INT), parameter, public :: ARK_RHSFUNC_FAIL = -8_C_INT
 integer(C_INT), parameter, public :: ARK_FIRST_RHSFUNC_ERR = -9_C_INT
 integer(C_INT), parameter, public :: ARK_REPTD_RHSFUNC_ERR = -10_C_INT
 integer(C_INT), parameter, public :: ARK_UNREC_RHSFUNC_ERR = -11_C_INT
 integer(C_INT), parameter, public :: ARK_RTFUNC_FAIL = -12_C_INT
 integer(C_INT), parameter, public :: ARK_LFREE_FAIL = -13_C_INT
 integer(C_INT), parameter, public :: ARK_MASSINIT_FAIL = -14_C_INT
 integer(C_INT), parameter, public :: ARK_MASSSETUP_FAIL = -15_C_INT
 integer(C_INT), parameter, public :: ARK_MASSSOLVE_FAIL = -16_C_INT
 integer(C_INT), parameter, public :: ARK_MASSFREE_FAIL = -17_C_INT
 integer(C_INT), parameter, public :: ARK_MASSMULT_FAIL = -18_C_INT
 integer(C_INT), parameter, public :: ARK_CONSTR_FAIL = -19_C_INT
 integer(C_INT), parameter, public :: ARK_MEM_FAIL = -20_C_INT
 integer(C_INT), parameter, public :: ARK_MEM_NULL = -21_C_INT
 integer(C_INT), parameter, public :: ARK_ILL_INPUT = -22_C_INT
 integer(C_INT), parameter, public :: ARK_NO_MALLOC = -23_C_INT
 integer(C_INT), parameter, public :: ARK_BAD_K = -24_C_INT
 integer(C_INT), parameter, public :: ARK_BAD_T = -25_C_INT
 integer(C_INT), parameter, public :: ARK_BAD_DKY = -26_C_INT
 integer(C_INT), parameter, public :: ARK_TOO_CLOSE = -27_C_INT
 integer(C_INT), parameter, public :: ARK_VECTOROP_ERR = -28_C_INT
 integer(C_INT), parameter, public :: ARK_NLS_INIT_FAIL = -29_C_INT
 integer(C_INT), parameter, public :: ARK_NLS_SETUP_FAIL = -30_C_INT
 integer(C_INT), parameter, public :: ARK_NLS_SETUP_RECVR = -31_C_INT
 integer(C_INT), parameter, public :: ARK_NLS_OP_ERR = -32_C_INT
 integer(C_INT), parameter, public :: ARK_INNERSTEP_ATTACH_ERR = -33_C_INT
 integer(C_INT), parameter, public :: ARK_INNERSTEP_FAIL = -34_C_INT
 integer(C_INT), parameter, public :: ARK_OUTERTOINNER_FAIL = -35_C_INT
 integer(C_INT), parameter, public :: ARK_INNERTOOUTER_FAIL = -36_C_INT
 integer(C_INT), parameter, public :: ARK_POSTPROCESS_FAIL = -37_C_INT
 integer(C_INT), parameter, public :: ARK_POSTPROCESS_STEP_FAIL = -37_C_INT
 integer(C_INT), parameter, public :: ARK_POSTPROCESS_STAGE_FAIL = -38_C_INT
 integer(C_INT), parameter, public :: ARK_USER_PREDICT_FAIL = -39_C_INT
 integer(C_INT), parameter, public :: ARK_INTERP_FAIL = -40_C_INT
 integer(C_INT), parameter, public :: ARK_INVALID_TABLE = -41_C_INT
 integer(C_INT), parameter, public :: ARK_CONTEXT_ERR = -42_C_INT
 integer(C_INT), parameter, public :: ARK_UNRECOGNIZED_ERROR = -99_C_INT
 public :: FARKBandPrecInit
 public :: FARKBandPrecGetWorkSpace
 public :: FARKBandPrecGetNumRhsEvals
 public :: FARKBBDPrecInit
 public :: FARKBBDPrecReInit
 public :: FARKBBDPrecGetWorkSpace
 public :: FARKBBDPrecGetNumGfnEvals

 integer, parameter :: swig_cmem_own_bit = 0
 integer, parameter :: swig_cmem_rvalue_bit = 1
 integer, parameter :: swig_cmem_const_bit = 2
 type, bind(C) :: SwigClassWrapper
  type(C_PTR), public :: cptr = C_NULL_PTR
  integer(C_INT), public :: cmemflags = 0
 end type
 ! struct struct ARKodeButcherTableMem
 type, public :: ARKodeButcherTableMem
  type(SwigClassWrapper), public :: swigdata
 contains
  procedure :: set_q => swigf_ARKodeButcherTableMem_q_set
  procedure :: get_q => swigf_ARKodeButcherTableMem_q_get
  procedure :: set_p => swigf_ARKodeButcherTableMem_p_set
  procedure :: get_p => swigf_ARKodeButcherTableMem_p_get
  procedure :: set_stages => swigf_ARKodeButcherTableMem_stages_set
  procedure :: get_stages => swigf_ARKodeButcherTableMem_stages_get
  procedure :: set_A => swigf_ARKodeButcherTableMem_A_set
  procedure :: get_A => swigf_ARKodeButcherTableMem_A_get
  procedure :: set_c => swigf_ARKodeButcherTableMem_c_set
  procedure :: get_c => swigf_ARKodeButcherTableMem_c_get
  procedure :: set_b => swigf_ARKodeButcherTableMem_b_set
  procedure :: get_b => swigf_ARKodeButcherTableMem_b_get
  procedure :: set_d => swigf_ARKodeButcherTableMem_d_set
  procedure :: get_d => swigf_ARKodeButcherTableMem_d_get
  procedure :: release => swigf_release_ARKodeButcherTableMem
  procedure, private :: swigf_ARKodeButcherTableMem_op_assign__
  generic :: assignment(=) => swigf_ARKodeButcherTableMem_op_assign__
 end type ARKodeButcherTableMem
 interface ARKodeButcherTableMem
  module procedure swigf_create_ARKodeButcherTableMem
 end interface
 public :: FARKodeButcherTable_Alloc
 public :: FARKodeButcherTable_Create
 public :: FARKodeButcherTable_Copy
 public :: FARKodeButcherTable_Space
 public :: FARKodeButcherTable_Free
 public :: FARKodeButcherTable_Write
 public :: FARKodeButcherTable_CheckOrder
 public :: FARKodeButcherTable_CheckARKOrder
 integer(C_INT), parameter, public :: SDIRK_2_1_2 = 100_C_INT
 integer(C_INT), parameter, public :: BILLINGTON_3_3_2 = 101_C_INT
 integer(C_INT), parameter, public :: TRBDF2_3_3_2 = 102_C_INT
 integer(C_INT), parameter, public :: KVAERNO_4_2_3 = 103_C_INT
 integer(C_INT), parameter, public :: ARK324L2SA_DIRK_4_2_3 = 104_C_INT
 integer(C_INT), parameter, public :: CASH_5_2_4 = 105_C_INT
 integer(C_INT), parameter, public :: CASH_5_3_4 = 106_C_INT
 integer(C_INT), parameter, public :: SDIRK_5_3_4 = 107_C_INT
 integer(C_INT), parameter, public :: KVAERNO_5_3_4 = 108_C_INT
 integer(C_INT), parameter, public :: ARK436L2SA_DIRK_6_3_4 = 109_C_INT
 integer(C_INT), parameter, public :: KVAERNO_7_4_5 = 110_C_INT
 integer(C_INT), parameter, public :: ARK548L2SA_DIRK_8_4_5 = 111_C_INT
 integer(C_INT), parameter, public :: ARK437L2SA_DIRK_7_3_4 = 112_C_INT
 integer(C_INT), parameter, public :: ARK548L2SAb_DIRK_8_4_5 = 113_C_INT
 integer(C_INT), parameter, public :: MIN_DIRK_NUM = 100_C_INT
 integer(C_INT), parameter, public :: MAX_DIRK_NUM = 113_C_INT
 ! typedef enum ARKODE_DIRKTableID
 enum, bind(c)
  enumerator :: ARKODE_DIRK_NONE = -1
  enumerator :: ARKODE_MIN_DIRK_NUM = 100
  enumerator :: ARKODE_SDIRK_2_1_2 = ARKODE_MIN_DIRK_NUM
  enumerator :: ARKODE_BILLINGTON_3_3_2
  enumerator :: ARKODE_TRBDF2_3_3_2
  enumerator :: ARKODE_KVAERNO_4_2_3
  enumerator :: ARKODE_ARK324L2SA_DIRK_4_2_3
  enumerator :: ARKODE_CASH_5_2_4
  enumerator :: ARKODE_CASH_5_3_4
  enumerator :: ARKODE_SDIRK_5_3_4
  enumerator :: ARKODE_KVAERNO_5_3_4
  enumerator :: ARKODE_ARK436L2SA_DIRK_6_3_4
  enumerator :: ARKODE_KVAERNO_7_4_5
  enumerator :: ARKODE_ARK548L2SA_DIRK_8_4_5
  enumerator :: ARKODE_ARK437L2SA_DIRK_7_3_4
  enumerator :: ARKODE_ARK548L2SAb_DIRK_8_4_5
  enumerator :: ARKODE_MAX_DIRK_NUM = ARKODE_ARK548L2SAb_DIRK_8_4_5
 end enum
 integer, parameter, public :: ARKODE_DIRKTableID = kind(ARKODE_DIRK_NONE)
 public :: ARKODE_DIRK_NONE, ARKODE_MIN_DIRK_NUM, ARKODE_SDIRK_2_1_2, ARKODE_BILLINGTON_3_3_2, ARKODE_TRBDF2_3_3_2, &
    ARKODE_KVAERNO_4_2_3, ARKODE_ARK324L2SA_DIRK_4_2_3, ARKODE_CASH_5_2_4, ARKODE_CASH_5_3_4, ARKODE_SDIRK_5_3_4, &
    ARKODE_KVAERNO_5_3_4, ARKODE_ARK436L2SA_DIRK_6_3_4, ARKODE_KVAERNO_7_4_5, ARKODE_ARK548L2SA_DIRK_8_4_5, &
    ARKODE_ARK437L2SA_DIRK_7_3_4, ARKODE_ARK548L2SAb_DIRK_8_4_5, ARKODE_MAX_DIRK_NUM
 public :: FARKodeButcherTable_LoadDIRK
 integer(C_INT), parameter, public :: HEUN_EULER_2_1_2 = 0_C_INT
 integer(C_INT), parameter, public :: BOGACKI_SHAMPINE_4_2_3 = 1_C_INT
 integer(C_INT), parameter, public :: ARK324L2SA_ERK_4_2_3 = 2_C_INT
 integer(C_INT), parameter, public :: ZONNEVELD_5_3_4 = 3_C_INT
 integer(C_INT), parameter, public :: ARK436L2SA_ERK_6_3_4 = 4_C_INT
 integer(C_INT), parameter, public :: SAYFY_ABURUB_6_3_4 = 5_C_INT
 integer(C_INT), parameter, public :: CASH_KARP_6_4_5 = 6_C_INT
 integer(C_INT), parameter, public :: FEHLBERG_6_4_5 = 7_C_INT
 integer(C_INT), parameter, public :: DORMAND_PRINCE_7_4_5 = 8_C_INT
 integer(C_INT), parameter, public :: ARK548L2SA_ERK_8_4_5 = 9_C_INT
 integer(C_INT), parameter, public :: VERNER_8_5_6 = 10_C_INT
 integer(C_INT), parameter, public :: FEHLBERG_13_7_8 = 11_C_INT
 integer(C_INT), parameter, public :: KNOTH_WOLKE_3_3 = 12_C_INT
 integer(C_INT), parameter, public :: ARK437L2SA_ERK_7_3_4 = 13_C_INT
 integer(C_INT), parameter, public :: ARK548L2SAb_ERK_8_4_5 = 14_C_INT
 integer(C_INT), parameter, public :: MIN_ERK_NUM = 0_C_INT
 integer(C_INT), parameter, public :: MAX_ERK_NUM = 14_C_INT
 ! typedef enum ARKODE_ERKTableID
 enum, bind(c)
  enumerator :: ARKODE_ERK_NONE = -1
  enumerator :: ARKODE_MIN_ERK_NUM = 0
  enumerator :: ARKODE_HEUN_EULER_2_1_2 = ARKODE_MIN_ERK_NUM
  enumerator :: ARKODE_BOGACKI_SHAMPINE_4_2_3
  enumerator :: ARKODE_ARK324L2SA_ERK_4_2_3
  enumerator :: ARKODE_ZONNEVELD_5_3_4
  enumerator :: ARKODE_ARK436L2SA_ERK_6_3_4
  enumerator :: ARKODE_SAYFY_ABURUB_6_3_4
  enumerator :: ARKODE_CASH_KARP_6_4_5
  enumerator :: ARKODE_FEHLBERG_6_4_5
  enumerator :: ARKODE_DORMAND_PRINCE_7_4_5
  enumerator :: ARKODE_ARK548L2SA_ERK_8_4_5
  enumerator :: ARKODE_VERNER_8_5_6
  enumerator :: ARKODE_FEHLBERG_13_7_8
  enumerator :: ARKODE_KNOTH_WOLKE_3_3
  enumerator :: ARKODE_ARK437L2SA_ERK_7_3_4
  enumerator :: ARKODE_ARK548L2SAb_ERK_8_4_5
  enumerator :: ARKODE_MAX_ERK_NUM = ARKODE_ARK548L2SAb_ERK_8_4_5
 end enum
 integer, parameter, public :: ARKODE_ERKTableID = kind(ARKODE_ERK_NONE)
 public :: ARKODE_ERK_NONE, ARKODE_MIN_ERK_NUM, ARKODE_HEUN_EULER_2_1_2, ARKODE_BOGACKI_SHAMPINE_4_2_3, &
    ARKODE_ARK324L2SA_ERK_4_2_3, ARKODE_ZONNEVELD_5_3_4, ARKODE_ARK436L2SA_ERK_6_3_4, ARKODE_SAYFY_ABURUB_6_3_4, &
    ARKODE_CASH_KARP_6_4_5, ARKODE_FEHLBERG_6_4_5, ARKODE_DORMAND_PRINCE_7_4_5, ARKODE_ARK548L2SA_ERK_8_4_5, &
    ARKODE_VERNER_8_5_6, ARKODE_FEHLBERG_13_7_8, ARKODE_KNOTH_WOLKE_3_3, ARKODE_ARK437L2SA_ERK_7_3_4, &
    ARKODE_ARK548L2SAb_ERK_8_4_5, ARKODE_MAX_ERK_NUM
 public :: FARKodeButcherTable_LoadERK
 integer(C_INT), parameter, public :: ARKLS_SUCCESS = 0_C_INT
 integer(C_INT), parameter, public :: ARKLS_MEM_NULL = -1_C_INT
 integer(C_INT), parameter, public :: ARKLS_LMEM_NULL = -2_C_INT
 integer(C_INT), parameter, public :: ARKLS_ILL_INPUT = -3_C_INT
 integer(C_INT), parameter, public :: ARKLS_MEM_FAIL = -4_C_INT
 integer(C_INT), parameter, public :: ARKLS_PMEM_NULL = -5_C_INT
 integer(C_INT), parameter, public :: ARKLS_MASSMEM_NULL = -6_C_INT
 integer(C_INT), parameter, public :: ARKLS_JACFUNC_UNRECVR = -7_C_INT
 integer(C_INT), parameter, public :: ARKLS_JACFUNC_RECVR = -8_C_INT
 integer(C_INT), parameter, public :: ARKLS_MASSFUNC_UNRECVR = -9_C_INT
 integer(C_INT), parameter, public :: ARKLS_MASSFUNC_RECVR = -10_C_INT
 integer(C_INT), parameter, public :: ARKLS_SUNMAT_FAIL = -11_C_INT
 integer(C_INT), parameter, public :: ARKLS_SUNLS_FAIL = -12_C_INT

! WRAPPER DECLARATIONS
interface
function swigc_FARKBandPrecInit(farg1, farg2, farg3, farg4) &
bind(C, name="_wrap_FARKBandPrecInit") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
integer(C_INT64_T), intent(in) :: farg2
integer(C_INT64_T), intent(in) :: farg3
integer(C_INT64_T), intent(in) :: farg4
integer(C_INT) :: fresult
end function

function swigc_FARKBandPrecGetWorkSpace(farg1, farg2, farg3) &
bind(C, name="_wrap_FARKBandPrecGetWorkSpace") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
type(C_PTR), value :: farg2
type(C_PTR), value :: farg3
integer(C_INT) :: fresult
end function

function swigc_FARKBandPrecGetNumRhsEvals(farg1, farg2) &
bind(C, name="_wrap_FARKBandPrecGetNumRhsEvals") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
type(C_PTR), value :: farg2
integer(C_INT) :: fresult
end function

function swigc_FARKBBDPrecInit(farg1, farg2, farg3, farg4, farg5, farg6, farg7, farg8, farg9) &
bind(C, name="_wrap_FARKBBDPrecInit") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
integer(C_INT64_T), intent(in) :: farg2
integer(C_INT64_T), intent(in) :: farg3
integer(C_INT64_T), intent(in) :: farg4
integer(C_INT64_T), intent(in) :: farg5
integer(C_INT64_T), intent(in) :: farg6
real(C_DOUBLE), intent(in) :: farg7
type(C_FUNPTR), value :: farg8
type(C_FUNPTR), value :: farg9
integer(C_INT) :: fresult
end function

function swigc_FARKBBDPrecReInit(farg1, farg2, farg3, farg4) &
bind(C, name="_wrap_FARKBBDPrecReInit") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
integer(C_INT64_T), intent(in) :: farg2
integer(C_INT64_T), intent(in) :: farg3
real(C_DOUBLE), intent(in) :: farg4
integer(C_INT) :: fresult
end function

function swigc_FARKBBDPrecGetWorkSpace(farg1, farg2, farg3) &
bind(C, name="_wrap_FARKBBDPrecGetWorkSpace") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
type(C_PTR), value :: farg2
type(C_PTR), value :: farg3
integer(C_INT) :: fresult
end function

function swigc_FARKBBDPrecGetNumGfnEvals(farg1, farg2) &
bind(C, name="_wrap_FARKBBDPrecGetNumGfnEvals") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
type(C_PTR), value :: farg2
integer(C_INT) :: fresult
end function

subroutine swigc_ARKodeButcherTableMem_q_set(farg1, farg2) &
bind(C, name="_wrap_ARKodeButcherTableMem_q_set")
use, intrinsic :: ISO_C_BINDING
import :: swigclasswrapper
type(SwigClassWrapper) :: farg1
integer(C_INT), intent(in) :: farg2
end subroutine

function swigc_ARKodeButcherTableMem_q_get(farg1) &
bind(C, name="_wrap_ARKodeButcherTableMem_q_get") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
import :: swigclasswrapper
type(SwigClassWrapper) :: farg1
integer(C_INT) :: fresult
end function

subroutine swigc_ARKodeButcherTableMem_p_set(farg1, farg2) &
bind(C, name="_wrap_ARKodeButcherTableMem_p_set")
use, intrinsic :: ISO_C_BINDING
import :: swigclasswrapper
type(SwigClassWrapper) :: farg1
integer(C_INT), intent(in) :: farg2
end subroutine

function swigc_ARKodeButcherTableMem_p_get(farg1) &
bind(C, name="_wrap_ARKodeButcherTableMem_p_get") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
import :: swigclasswrapper
type(SwigClassWrapper) :: farg1
integer(C_INT) :: fresult
end function

subroutine swigc_ARKodeButcherTableMem_stages_set(farg1, farg2) &
bind(C, name="_wrap_ARKodeButcherTableMem_stages_set")
use, intrinsic :: ISO_C_BINDING
import :: swigclasswrapper
type(SwigClassWrapper) :: farg1
integer(C_INT), intent(in) :: farg2
end subroutine

function swigc_ARKodeButcherTableMem_stages_get(farg1) &
bind(C, name="_wrap_ARKodeButcherTableMem_stages_get") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
import :: swigclasswrapper
type(SwigClassWrapper) :: farg1
integer(C_INT) :: fresult
end function

subroutine swigc_ARKodeButcherTableMem_A_set(farg1, farg2) &
bind(C, name="_wrap_ARKodeButcherTableMem_A_set")
use, intrinsic :: ISO_C_BINDING
import :: swigclasswrapper
type(SwigClassWrapper) :: farg1
type(C_PTR), value :: farg2
end subroutine

function swigc_ARKodeButcherTableMem_A_get(farg1) &
bind(C, name="_wrap_ARKodeButcherTableMem_A_get") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
import :: swigclasswrapper
type(SwigClassWrapper) :: farg1
type(C_PTR) :: fresult
end function

subroutine swigc_ARKodeButcherTableMem_c_set(farg1, farg2) &
bind(C, name="_wrap_ARKodeButcherTableMem_c_set")
use, intrinsic :: ISO_C_BINDING
import :: swigclasswrapper
type(SwigClassWrapper) :: farg1
type(C_PTR), value :: farg2
end subroutine

function swigc_ARKodeButcherTableMem_c_get(farg1) &
bind(C, name="_wrap_ARKodeButcherTableMem_c_get") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
import :: swigclasswrapper
type(SwigClassWrapper) :: farg1
type(C_PTR) :: fresult
end function

subroutine swigc_ARKodeButcherTableMem_b_set(farg1, farg2) &
bind(C, name="_wrap_ARKodeButcherTableMem_b_set")
use, intrinsic :: ISO_C_BINDING
import :: swigclasswrapper
type(SwigClassWrapper) :: farg1
type(C_PTR), value :: farg2
end subroutine

function swigc_ARKodeButcherTableMem_b_get(farg1) &
bind(C, name="_wrap_ARKodeButcherTableMem_b_get") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
import :: swigclasswrapper
type(SwigClassWrapper) :: farg1
type(C_PTR) :: fresult
end function

subroutine swigc_ARKodeButcherTableMem_d_set(farg1, farg2) &
bind(C, name="_wrap_ARKodeButcherTableMem_d_set")
use, intrinsic :: ISO_C_BINDING
import :: swigclasswrapper
type(SwigClassWrapper) :: farg1
type(C_PTR), value :: farg2
end subroutine

function swigc_ARKodeButcherTableMem_d_get(farg1) &
bind(C, name="_wrap_ARKodeButcherTableMem_d_get") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
import :: swigclasswrapper
type(SwigClassWrapper) :: farg1
type(C_PTR) :: fresult
end function

function swigc_new_ARKodeButcherTableMem() &
bind(C, name="_wrap_new_ARKodeButcherTableMem") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
import :: swigclasswrapper
type(SwigClassWrapper) :: fresult
end function

subroutine swigc_delete_ARKodeButcherTableMem(farg1) &
bind(C, name="_wrap_delete_ARKodeButcherTableMem")
use, intrinsic :: ISO_C_BINDING
import :: swigclasswrapper
type(SwigClassWrapper), intent(inout) :: farg1
end subroutine

subroutine swigc_ARKodeButcherTableMem_op_assign__(farg1, farg2) &
bind(C, name="_wrap_ARKodeButcherTableMem_op_assign__")
use, intrinsic :: ISO_C_BINDING
import :: swigclasswrapper
type(SwigClassWrapper), intent(inout) :: farg1
type(SwigClassWrapper) :: farg2
end subroutine

function swigc_FARKodeButcherTable_Alloc(farg1, farg2) &
bind(C, name="_wrap_FARKodeButcherTable_Alloc") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
integer(C_INT), intent(in) :: farg1
integer(C_INT), intent(in) :: farg2
type(C_PTR) :: fresult
end function

function swigc_FARKodeButcherTable_Create(farg1, farg2, farg3, farg4, farg5, farg6, farg7) &
bind(C, name="_wrap_FARKodeButcherTable_Create") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
integer(C_INT), intent(in) :: farg1
integer(C_INT), intent(in) :: farg2
integer(C_INT), intent(in) :: farg3
type(C_PTR), value :: farg4
type(C_PTR), value :: farg5
type(C_PTR), value :: farg6
type(C_PTR), value :: farg7
type(C_PTR) :: fresult
end function

function swigc_FARKodeButcherTable_Copy(farg1) &
bind(C, name="_wrap_FARKodeButcherTable_Copy") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
type(C_PTR) :: fresult
end function

subroutine swigc_FARKodeButcherTable_Space(farg1, farg2, farg3) &
bind(C, name="_wrap_FARKodeButcherTable_Space")
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
type(C_PTR), value :: farg2
type(C_PTR), value :: farg3
end subroutine

subroutine swigc_FARKodeButcherTable_Free(farg1) &
bind(C, name="_wrap_FARKodeButcherTable_Free")
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
end subroutine

subroutine swigc_FARKodeButcherTable_Write(farg1, farg2) &
bind(C, name="_wrap_FARKodeButcherTable_Write")
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
type(C_PTR), value :: farg2
end subroutine

function swigc_FARKodeButcherTable_CheckOrder(farg1, farg2, farg3, farg4) &
bind(C, name="_wrap_FARKodeButcherTable_CheckOrder") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
type(C_PTR), value :: farg2
type(C_PTR), value :: farg3
type(C_PTR), value :: farg4
integer(C_INT) :: fresult
end function

function swigc_FARKodeButcherTable_CheckARKOrder(farg1, farg2, farg3, farg4, farg5) &
bind(C, name="_wrap_FARKodeButcherTable_CheckARKOrder") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
type(C_PTR), value :: farg2
type(C_PTR), value :: farg3
type(C_PTR), value :: farg4
type(C_PTR), value :: farg5
integer(C_INT) :: fresult
end function

function swigc_FARKodeButcherTable_LoadDIRK(farg1) &
bind(C, name="_wrap_FARKodeButcherTable_LoadDIRK") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
integer(C_INT), intent(in) :: farg1
type(C_PTR) :: fresult
end function

function swigc_FARKodeButcherTable_LoadERK(farg1) &
bind(C, name="_wrap_FARKodeButcherTable_LoadERK") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
integer(C_INT), intent(in) :: farg1
type(C_PTR) :: fresult
end function

end interface

contains
 ! MODULE SUBPROGRAMS
function FARKBandPrecInit(arkode_mem, n, mu, ml) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
type(C_PTR) :: arkode_mem
integer(C_INT64_T), intent(in) :: n
integer(C_INT64_T), intent(in) :: mu
integer(C_INT64_T), intent(in) :: ml
integer(C_INT) :: fresult
type(C_PTR) :: farg1
integer(C_INT64_T) :: farg2
integer(C_INT64_T) :: farg3
integer(C_INT64_T) :: farg4

farg1 = arkode_mem
farg2 = n
farg3 = mu
farg4 = ml
fresult = swigc_FARKBandPrecInit(farg1, farg2, farg3, farg4)
swig_result = fresult
end function

function FARKBandPrecGetWorkSpace(arkode_mem, lenrwls, leniwls) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
type(C_PTR) :: arkode_mem
integer(C_LONG), dimension(*), target, intent(inout) :: lenrwls
integer(C_LONG), dimension(*), target, intent(inout) :: leniwls
integer(C_INT) :: fresult
type(C_PTR) :: farg1
type(C_PTR) :: farg2
type(C_PTR) :: farg3

farg1 = arkode_mem
farg2 = c_loc(lenrwls(1))
farg3 = c_loc(leniwls(1))
fresult = swigc_FARKBandPrecGetWorkSpace(farg1, farg2, farg3)
swig_result = fresult
end function

function FARKBandPrecGetNumRhsEvals(arkode_mem, nfevalsbp) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
type(C_PTR) :: arkode_mem
integer(C_LONG), dimension(*), target, intent(inout) :: nfevalsbp
integer(C_INT) :: fresult
type(C_PTR) :: farg1
type(C_PTR) :: farg2

farg1 = arkode_mem
farg2 = c_loc(nfevalsbp(1))
fresult = swigc_FARKBandPrecGetNumRhsEvals(farg1, farg2)
swig_result = fresult
end function

function FARKBBDPrecInit(arkode_mem, nlocal, mudq, mldq, mukeep, mlkeep, dqrely, gloc, cfn) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
type(C_PTR) :: arkode_mem
integer(C_INT64_T), intent(in) :: nlocal
integer(C_INT64_T), intent(in) :: mudq
integer(C_INT64_T), intent(in) :: mldq
integer(C_INT64_T), intent(in) :: mukeep
integer(C_INT64_T), intent(in) :: mlkeep
real(C_DOUBLE), intent(in) :: dqrely
type(C_FUNPTR), intent(in), value :: gloc
type(C_FUNPTR), intent(in), value :: cfn
integer(C_INT) :: fresult
type(C_PTR) :: farg1
integer(C_INT64_T) :: farg2
integer(C_INT64_T) :: farg3
integer(C_INT64_T) :: farg4
integer(C_INT64_T) :: farg5
integer(C_INT64_T) :: farg6
real(C_DOUBLE) :: farg7
type(C_FUNPTR) :: farg8
type(C_FUNPTR) :: farg9

farg1 = arkode_mem
farg2 = nlocal
farg3 = mudq
farg4 = mldq
farg5 = mukeep
farg6 = mlkeep
farg7 = dqrely
farg8 = gloc
farg9 = cfn
fresult = swigc_FARKBBDPrecInit(farg1, farg2, farg3, farg4, farg5, farg6, farg7, farg8, farg9)
swig_result = fresult
end function

function FARKBBDPrecReInit(arkode_mem, mudq, mldq, dqrely) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
type(C_PTR) :: arkode_mem
integer(C_INT64_T), intent(in) :: mudq
integer(C_INT64_T), intent(in) :: mldq
real(C_DOUBLE), intent(in) :: dqrely
integer(C_INT) :: fresult
type(C_PTR) :: farg1
integer(C_INT64_T) :: farg2
integer(C_INT64_T) :: farg3
real(C_DOUBLE) :: farg4

farg1 = arkode_mem
farg2 = mudq
farg3 = mldq
farg4 = dqrely
fresult = swigc_FARKBBDPrecReInit(farg1, farg2, farg3, farg4)
swig_result = fresult
end function

function FARKBBDPrecGetWorkSpace(arkode_mem, lenrwbbdp, leniwbbdp) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
type(C_PTR) :: arkode_mem
integer(C_LONG), dimension(*), target, intent(inout) :: lenrwbbdp
integer(C_LONG), dimension(*), target, intent(inout) :: leniwbbdp
integer(C_INT) :: fresult
type(C_PTR) :: farg1
type(C_PTR) :: farg2
type(C_PTR) :: farg3

farg1 = arkode_mem
farg2 = c_loc(lenrwbbdp(1))
farg3 = c_loc(leniwbbdp(1))
fresult = swigc_FARKBBDPrecGetWorkSpace(farg1, farg2, farg3)
swig_result = fresult
end function

function FARKBBDPrecGetNumGfnEvals(arkode_mem, ngevalsbbdp) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
type(C_PTR) :: arkode_mem
integer(C_LONG), dimension(*), target, intent(inout) :: ngevalsbbdp
integer(C_INT) :: fresult
type(C_PTR) :: farg1
type(C_PTR) :: farg2

farg1 = arkode_mem
farg2 = c_loc(ngevalsbbdp(1))
fresult = swigc_FARKBBDPrecGetNumGfnEvals(farg1, farg2)
swig_result = fresult
end function

subroutine swigf_ARKodeButcherTableMem_q_set(self, q)
use, intrinsic :: ISO_C_BINDING
class(ARKodeButcherTableMem), intent(in) :: self
integer(C_INT), intent(in) :: q
type(SwigClassWrapper) :: farg1
integer(C_INT) :: farg2

farg1 = self%swigdata
farg2 = q
call swigc_ARKodeButcherTableMem_q_set(farg1, farg2)
end subroutine

function swigf_ARKodeButcherTableMem_q_get(self) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
class(ARKodeButcherTableMem), intent(in) :: self
integer(C_INT) :: fresult
type(SwigClassWrapper) :: farg1

farg1 = self%swigdata
fresult = swigc_ARKodeButcherTableMem_q_get(farg1)
swig_result = fresult
end function

subroutine swigf_ARKodeButcherTableMem_p_set(self, p)
use, intrinsic :: ISO_C_BINDING
class(ARKodeButcherTableMem), intent(in) :: self
integer(C_INT), intent(in) :: p
type(SwigClassWrapper) :: farg1
integer(C_INT) :: farg2

farg1 = self%swigdata
farg2 = p
call swigc_ARKodeButcherTableMem_p_set(farg1, farg2)
end subroutine

function swigf_ARKodeButcherTableMem_p_get(self) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
class(ARKodeButcherTableMem), intent(in) :: self
integer(C_INT) :: fresult
type(SwigClassWrapper) :: farg1

farg1 = self%swigdata
fresult = swigc_ARKodeButcherTableMem_p_get(farg1)
swig_result = fresult
end function

subroutine swigf_ARKodeButcherTableMem_stages_set(self, stages)
use, intrinsic :: ISO_C_BINDING
class(ARKodeButcherTableMem), intent(in) :: self
integer(C_INT), intent(in) :: stages
type(SwigClassWrapper) :: farg1
integer(C_INT) :: farg2

farg1 = self%swigdata
farg2 = stages
call swigc_ARKodeButcherTableMem_stages_set(farg1, farg2)
end subroutine

function swigf_ARKodeButcherTableMem_stages_get(self) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
class(ARKodeButcherTableMem), intent(in) :: self
integer(C_INT) :: fresult
type(SwigClassWrapper) :: farg1

farg1 = self%swigdata
fresult = swigc_ARKodeButcherTableMem_stages_get(farg1)
swig_result = fresult
end function

subroutine swigf_ARKodeButcherTableMem_A_set(self, a)
use, intrinsic :: ISO_C_BINDING
class(ARKodeButcherTableMem), intent(in) :: self
type(C_PTR), target, intent(inout) :: a
type(SwigClassWrapper) :: farg1
type(C_PTR) :: farg2

farg1 = self%swigdata
farg2 = c_loc(a)
call swigc_ARKodeButcherTableMem_A_set(farg1, farg2)
end subroutine

function swigf_ARKodeButcherTableMem_A_get(self) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), pointer :: swig_result
class(ARKodeButcherTableMem), intent(in) :: self
type(C_PTR) :: fresult
type(SwigClassWrapper) :: farg1

farg1 = self%swigdata
fresult = swigc_ARKodeButcherTableMem_A_get(farg1)
call c_f_pointer(fresult, swig_result)
end function

subroutine swigf_ARKodeButcherTableMem_c_set(self, c)
use, intrinsic :: ISO_C_BINDING
class(ARKodeButcherTableMem), intent(in) :: self
real(C_DOUBLE), dimension(*), target, intent(inout) :: c
type(SwigClassWrapper) :: farg1
type(C_PTR) :: farg2

farg1 = self%swigdata
farg2 = c_loc(c(1))
call swigc_ARKodeButcherTableMem_c_set(farg1, farg2)
end subroutine

function swigf_ARKodeButcherTableMem_c_get(self) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
real(C_DOUBLE), dimension(:), pointer :: swig_result
class(ARKodeButcherTableMem), intent(in) :: self
type(C_PTR) :: fresult
type(SwigClassWrapper) :: farg1

farg1 = self%swigdata
fresult = swigc_ARKodeButcherTableMem_c_get(farg1)
call c_f_pointer(fresult, swig_result, [1])
end function

subroutine swigf_ARKodeButcherTableMem_b_set(self, b)
use, intrinsic :: ISO_C_BINDING
class(ARKodeButcherTableMem), intent(in) :: self
real(C_DOUBLE), dimension(*), target, intent(inout) :: b
type(SwigClassWrapper) :: farg1
type(C_PTR) :: farg2

farg1 = self%swigdata
farg2 = c_loc(b(1))
call swigc_ARKodeButcherTableMem_b_set(farg1, farg2)
end subroutine

function swigf_ARKodeButcherTableMem_b_get(self) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
real(C_DOUBLE), dimension(:), pointer :: swig_result
class(ARKodeButcherTableMem), intent(in) :: self
type(C_PTR) :: fresult
type(SwigClassWrapper) :: farg1

farg1 = self%swigdata
fresult = swigc_ARKodeButcherTableMem_b_get(farg1)
call c_f_pointer(fresult, swig_result, [1])
end function

subroutine swigf_ARKodeButcherTableMem_d_set(self, d)
use, intrinsic :: ISO_C_BINDING
class(ARKodeButcherTableMem), intent(in) :: self
real(C_DOUBLE), dimension(*), target, intent(inout) :: d
type(SwigClassWrapper) :: farg1
type(C_PTR) :: farg2

farg1 = self%swigdata
farg2 = c_loc(d(1))
call swigc_ARKodeButcherTableMem_d_set(farg1, farg2)
end subroutine

function swigf_ARKodeButcherTableMem_d_get(self) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
real(C_DOUBLE), dimension(:), pointer :: swig_result
class(ARKodeButcherTableMem), intent(in) :: self
type(C_PTR) :: fresult
type(SwigClassWrapper) :: farg1

farg1 = self%swigdata
fresult = swigc_ARKodeButcherTableMem_d_get(farg1)
call c_f_pointer(fresult, swig_result, [1])
end function

function swigf_create_ARKodeButcherTableMem() &
result(self)
use, intrinsic :: ISO_C_BINDING
type(ARKodeButcherTableMem) :: self
type(SwigClassWrapper) :: fresult

fresult = swigc_new_ARKodeButcherTableMem()
self%swigdata = fresult
end function

subroutine swigf_release_ARKodeButcherTableMem(self)
use, intrinsic :: ISO_C_BINDING
class(ARKodeButcherTableMem), intent(inout) :: self
type(SwigClassWrapper) :: farg1

farg1 = self%swigdata
if (btest(farg1%cmemflags, swig_cmem_own_bit)) then
call swigc_delete_ARKodeButcherTableMem(farg1)
endif
farg1%cptr = C_NULL_PTR
farg1%cmemflags = 0
self%swigdata = farg1
end subroutine

subroutine swigf_ARKodeButcherTableMem_op_assign__(self, other)
use, intrinsic :: ISO_C_BINDING
class(ARKodeButcherTableMem), intent(inout) :: self
type(ARKodeButcherTableMem), intent(in) :: other
type(SwigClassWrapper) :: farg1
type(SwigClassWrapper) :: farg2

farg1 = self%swigdata
farg2 = other%swigdata
call swigc_ARKodeButcherTableMem_op_assign__(farg1, farg2)
self%swigdata = farg1
end subroutine

function FARKodeButcherTable_Alloc(stages, embedded) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
type(C_PTR) :: swig_result
integer(C_INT), intent(in) :: stages
integer(C_INT), intent(in) :: embedded
type(C_PTR) :: fresult
integer(C_INT) :: farg1
integer(C_INT) :: farg2

farg1 = stages
farg2 = embedded
fresult = swigc_FARKodeButcherTable_Alloc(farg1, farg2)
swig_result = fresult
end function

function FARKodeButcherTable_Create(s, q, p, c, a, b, d) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
type(C_PTR) :: swig_result
integer(C_INT), intent(in) :: s
integer(C_INT), intent(in) :: q
integer(C_INT), intent(in) :: p
real(C_DOUBLE), dimension(*), target, intent(inout) :: c
real(C_DOUBLE), dimension(*), target, intent(inout) :: a
real(C_DOUBLE), dimension(*), target, intent(inout) :: b
real(C_DOUBLE), dimension(*), target, intent(inout) :: d
type(C_PTR) :: fresult
integer(C_INT) :: farg1
integer(C_INT) :: farg2
integer(C_INT) :: farg3
type(C_PTR) :: farg4
type(C_PTR) :: farg5
type(C_PTR) :: farg6
type(C_PTR) :: farg7

farg1 = s
farg2 = q
farg3 = p
farg4 = c_loc(c(1))
farg5 = c_loc(a(1))
farg6 = c_loc(b(1))
farg7 = c_loc(d(1))
fresult = swigc_FARKodeButcherTable_Create(farg1, farg2, farg3, farg4, farg5, farg6, farg7)
swig_result = fresult
end function

function FARKodeButcherTable_Copy(b) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
type(C_PTR) :: swig_result
type(C_PTR) :: b
type(C_PTR) :: fresult
type(C_PTR) :: farg1

farg1 = b
fresult = swigc_FARKodeButcherTable_Copy(farg1)
swig_result = fresult
end function

subroutine FARKodeButcherTable_Space(b, liw, lrw)
use, intrinsic :: ISO_C_BINDING
type(C_PTR) :: b
integer(C_INT64_T), dimension(*), target, intent(inout) :: liw
integer(C_INT64_T), dimension(*), target, intent(inout) :: lrw
type(C_PTR) :: farg1
type(C_PTR) :: farg2
type(C_PTR) :: farg3

farg1 = b
farg2 = c_loc(liw(1))
farg3 = c_loc(lrw(1))
call swigc_FARKodeButcherTable_Space(farg1, farg2, farg3)
end subroutine

subroutine FARKodeButcherTable_Free(b)
use, intrinsic :: ISO_C_BINDING
type(C_PTR) :: b
type(C_PTR) :: farg1

farg1 = b
call swigc_FARKodeButcherTable_Free(farg1)
end subroutine

subroutine FARKodeButcherTable_Write(b, outfile)
use, intrinsic :: ISO_C_BINDING
type(C_PTR) :: b
type(C_PTR) :: outfile
type(C_PTR) :: farg1
type(C_PTR) :: farg2

farg1 = b
farg2 = outfile
call swigc_FARKodeButcherTable_Write(farg1, farg2)
end subroutine

function FARKodeButcherTable_CheckOrder(b, q, p, outfile) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
type(C_PTR) :: b
integer(C_INT), dimension(*), target, intent(inout) :: q
integer(C_INT), dimension(*), target, intent(inout) :: p
type(C_PTR) :: outfile
integer(C_INT) :: fresult
type(C_PTR) :: farg1
type(C_PTR) :: farg2
type(C_PTR) :: farg3
type(C_PTR) :: farg4

farg1 = b
farg2 = c_loc(q(1))
farg3 = c_loc(p(1))
farg4 = outfile
fresult = swigc_FARKodeButcherTable_CheckOrder(farg1, farg2, farg3, farg4)
swig_result = fresult
end function

function FARKodeButcherTable_CheckARKOrder(b1, b2, q, p, outfile) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
type(C_PTR) :: b1
type(C_PTR) :: b2
integer(C_INT), dimension(*), target, intent(inout) :: q
integer(C_INT), dimension(*), target, intent(inout) :: p
type(C_PTR) :: outfile
integer(C_INT) :: fresult
type(C_PTR) :: farg1
type(C_PTR) :: farg2
type(C_PTR) :: farg3
type(C_PTR) :: farg4
type(C_PTR) :: farg5

farg1 = b1
farg2 = b2
farg3 = c_loc(q(1))
farg4 = c_loc(p(1))
farg5 = outfile
fresult = swigc_FARKodeButcherTable_CheckARKOrder(farg1, farg2, farg3, farg4, farg5)
swig_result = fresult
end function

function FARKodeButcherTable_LoadDIRK(imethod) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
type(C_PTR) :: swig_result
integer(ARKODE_DIRKTableID), intent(in) :: imethod
type(C_PTR) :: fresult
integer(C_INT) :: farg1

farg1 = imethod
fresult = swigc_FARKodeButcherTable_LoadDIRK(farg1)
swig_result = fresult
end function

function FARKodeButcherTable_LoadERK(imethod) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
type(C_PTR) :: swig_result
integer(ARKODE_ERKTableID), intent(in) :: imethod
type(C_PTR) :: fresult
integer(C_INT) :: farg1

farg1 = imethod
fresult = swigc_FARKodeButcherTable_LoadERK(farg1)
swig_result = fresult
end function

end module

max_stars_repo_name: chrispbradley/sundials

max_issues_repo_name: chrispbradley/sundials

max_forks_repo_name: chrispbradley/sundials


text:
PROGRAM wlRewriteEquationOfStateTest

  USE wlKindModule, ONLY: DP
  USE wlExtNumericalModule, ONLY: epsilon
  USE wlDependentVariablesModule
  USE HDF5
  USE wlThermoStateModule
  USE wlGridModule, ONLY: MakeLinearGrid, MakeLogGrid
  USE wlEquationOfStateTableModule
  USE wlIOModuleHDF
  USE wlEOSIOModuleHDF
  USE wlEOSInterpolationModule, ONLY: &
      EOSTableQuery

  implicit none

  INTEGER                        :: i, i_rho, i_t, i_ye, ivar
  INTEGER, DIMENSION(3)          :: nPoints
  INTEGER                        :: nVariables
  INTEGER                        :: j
  TYPE(EquationOfStateTableType) :: EOSInTable, EOSOutTable
  INTEGER(HID_T)                 :: file_id
  INTEGER(HID_T)                 :: group_id
  REAL(DP)                       :: minvar, maxvar
  REAL(DP), ALLOCATABLE          :: Interpolants(:,:)
  REAL(DP), ALLOCATABLE          :: t(:), ye(:)

  CALL InitializeHDF( )

  CALL ReadEquationOfStateTableHDF &
       ( EOSInTable, "wl-EOS-LS220-20-40-100-Lower-T.h5" )

  !! ----- USE FOR REWRITE OLD TABLE WITH ADDING MIN-MAX
!!$  nPoints = EOSInTable % DV % nPoints
!!$  nVariables = EOSInTable % DV % nVariables
!!$
!!$  CALL AllocateEquationOfStateTable( EOSOutTable, nPoints , nVariables )
!!$
!!$  EOSOutTable % TS = EOSInTable % TS
!!$  EOSOutTable % DV = EOSInTable % DV
!!$  EOSOutTable % MD = EOSInTable % MD
!!$
!!$  DO ivar = 1, EOSOutTable % DV % nVariables
!!$    minvar = MINVAL( EOSOutTable % DV % Variables(ivar) % Values )
!!$    EOSOutTable % DV % minValues(ivar) &
!!$    = 10.0d0**minvar - EOSOutTable % DV % Offsets(ivar)
!!$
!!$    maxvar = MAXVAL( EOSOutTable % DV % Variables(ivar) % Values )
!!$    EOSOutTable % DV % maxValues(ivar) &
!!$    = 10.0d0**maxvar - EOSOutTable % DV % Offsets(ivar)
!!$  END DO
!!$
!!$  CALL InitializeHDF( )
!!$  CALL WriteEquationOfStateTableHDF( EOSOutTable, &
!!$       "wl-EOS-LS220-20-40-100-Lower-T-rewrite.h5" )
!!$  CALL DeAllocateEquationOfStateTable( EOSOutTable )

  !! ------ USE FOR COARSING EOS TABLE
  nPoints = (/121,68,25/)
  nVariables = EOSInTable % DV % nVariables

  ALLOCATE( t(nPoints(1)) )
  ALLOCATE( ye(nPoints(1)) )
  ALLOCATE( Interpolants(nPoints(1),nVariables) )

  CALL AllocateEquationOfStateTable( EOSOutTable, nPoints , nVariables )

  EOSOutTable % TS % Names = EOSInTable % TS % Names
  EOSOutTable % TS % Units = EOSInTable % TS % Units
  EOSOutTable % TS % Indices = EOSInTable % TS % Indices
  EOSOutTable % TS % LogInterp = EOSInTable % TS % LogInterp
  EOSOutTable % TS % minValues = EOSInTable % TS % minValues
  EOSOutTable % TS % maxValues = EOSInTable % TS % maxValues

  CALL MakeLogGrid( EOSOutTable % TS % minValues(1), EOSOutTable % TS % maxValues(1),&
         EOSOutTable % TS % nPoints(1), EOSOutTable % TS % States(1) % Values)
  CALL MakeLogGrid( EOSOutTable % TS % minValues(2), EOSOutTable % TS % maxValues(2),&
         EOSOutTable % TS % nPoints(2), EOSOutTable % TS % States(2) % Values)
  CALL MakeLinearGrid( EOSOutTable % TS % minValues(3), EOSOutTable % TS % maxValues(3),&
         EOSOutTable % TS % nPoints(3), EOSOutTable % TS % States(3) % Values)

  EOSOutTable % DV % nVariables = EOSInTable % DV % nVariables
  EOSOutTable % DV % nPoints = nPoints
  EOSOutTable % DV % Names = EOSInTable % DV % Names
  EOSOutTable % DV % Units = EOSInTable % DV % Units
  EOSOutTable % DV % Indices = EOSInTable % DV % Indices

  ASSOCIATE &
  ( iRho => EOSOutTable % TS % Indices % iRho, &
    iT   => EOSOutTable % TS % Indices % iT, &
    iYe  => EOSOutTable % TS % Indices % iYe )

    DO i_ye = 1,nPoints(iYe)
      ye = EOSOutTable % TS % States(iYe) % Values(i_ye)
      DO i_t = 1,nPoints(iT)
        t = EOSOutTable % TS % States(iT) % Values(i_t)
        DO i_rho = 1,nPoints(iRho)

          CALL EOSTableQuery &
               ( EOSOutTable % TS % States(iRho) % Values, &
                 t, ye, &
                 EOSOutTable % TS % LogInterp, &
                 EOSInTable  % TS, EOSInTable % DV, Interpolants )

          DO ivar = 1,EOSOutTable % DV % nVariables
             EOSOutTable % DV % Variables(ivar) % Values(:,i_t,i_ye) &
             = Interpolants(:,ivar)
          END DO

        END DO
      END DO
    END DO

  END ASSOCIATE

  DO ivar = 1, EOSOutTable % DV % nVariables
    minvar = MINVAL( EOSOutTable % DV % Variables(ivar) % Values )
    EOSOutTable % DV % minValues(ivar) = minvar

    maxvar = MAXVAL( EOSOutTable % DV % Variables(ivar) % Values )
    EOSOutTable % DV % maxValues(ivar) = maxvar

    EOSOutTable % DV % Offsets(ivar) = -2.d0 * MIN( 0.d0, minvar )

    EOSOutTable % DV % Variables(ivar) % Values &
      = LOG10( EOSOutTable % DV % Variables(ivar) % Values &
               + EOSOutTable % DV % Offsets(ivar) + epsilon )
  END DO

  CALL InitializeHDF( )
  CALL WriteEquationOfStateTableHDF &
       ( EOSOutTable, "wl-EOS-LS220-15-25-50-Lower-T-rewrite.h5" )
  CALL FinalizeHDF( )

  DEALLOCATE( t, ye, Interpolants )
  CALL DeAllocateEquationOfStateTable( EOSInTable )
  CALL DeAllocateEquationOfStateTable( EOSOutTable )

  WRITE (*,*) "HDF write successful"

END PROGRAM wlRewriteEquationOfStateTest

max_stars_repo_name: srichers/weaklib


text:
! This file is generated!
module implementation
implicit none
  interface

    subroutine copy_from_data_store(arg0, arg1) bind(c)
      use iso_c_binding
      type(c_ptr), value :: arg0
      real(c_double), dimension(*) :: arg1
    end subroutine
    subroutine copy_to_data_store(arg0, arg1) bind(c)
      use iso_c_binding
      type(c_ptr), value :: arg0
      real(c_double), dimension(*) :: arg1
    end subroutine
    type(c_ptr) function create_data_store(arg0, arg1, arg2) bind(c)
      use iso_c_binding
      integer(c_int), value :: arg0
      integer(c_int), value :: arg1
      integer(c_int), value :: arg2
    end function
    subroutine run_copy_stencil(arg0, arg1) bind(c)
      use iso_c_binding
      type(c_ptr), value :: arg0
      type(c_ptr), value :: arg1
    end subroutine

  end interface
contains
end

max_stars_repo_name: aurianer/gridtools

max_issues_repo_name: aurianer/gridtools

max_forks_repo_name: aurianer/gridtools


text:
      subroutine edit(imsgin,xmsgin,cmsgin,msgtype,nwds,ierror)
C
C
C#######################################################################
C
C     PURPOSE -
C
C        THIS ROUTINE GENERATES EDITS OF VARIOUS QUANTITIES ASSOCIATED
C        WITH GROUPS OF POINTS OR PARTS.  THE FORMAT OF THE COMMAND IS
C
C           EDIT/iopt/point1,point2,increment/partname
C
C           EDIT/ANGULAR/point1,point2,increment/partname/xcen,ycen,zcen
C
C           EDIT/POINTS/point1,point2,increment/partname/array1,array2,
C                       array3,array4 (cell center arrays)
C
C           EDIT/RADIAL/point1,point2,increment/partname/xcen,ycen,zcen
C
C        FOR THE FOLLOWING VALUES OF iopt:
C
C           'partsmry'  - SUMMARY EDIT BY MATERIAL REGION
C
C           'parts'     - LIST OF MATERIAL REGIONS
C
C           'angular'   - ANGULAR VELOCITY SUMMARY FOR SET OF POINTS
C
C           'two'       - AVERAGES AND SUMS FOR point1 AND point2
C
C           'points'    - nodmesh ARRAY VALUES FOR SET OF POINTS
C
C           'radial'    - RADIAL DATA FOR SET OF POINTS
C
C           unspecified - AVERAGES AND SUMS FOR SPECIFIED SET OF POINTS.
C
C
C     INPUT ARGUMENTS -
C
C        imsgin()  - Integer array of command input tokens
C        xmsgin()  - Real array of command input tokens
C        cmsgin()  - Character array of command input tokens
C        msgtype() - Integer array of command input token types
C        nwds      - Number of command input tokens
C
C     OUTPUT ARGUMENTS -
C
C        ierror - Error Return Code (==0 ==> OK, <>0 ==> Error)
C
C     CHANGE HISTORY -
C
C        $Log: edit.f,v $
C        Revision 2.00  2007/11/05 19:45:53  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.5   30 Sep 2004 09:02:58   dcg
CPVCS     change call to real to call to dble
CPVCS
CPVCS       Rev 1.4   Wed Apr 05 13:34:18 2000   nnc
CPVCS    Minor source modifications required by the Absoft compiler.
CPVCS
CPVCS       Rev 1.3   Tue Feb 08 15:24:48 2000   dcg
CPVCS
CPVCS       Rev 1.2   Tue Feb 08 14:53:22 2000   dcg
CPVCS
CPVCS       Rev 1.1   Thu Feb 03 08:48:24 2000   dcg
CPVCS
CPVCS       Rev 1.0   26 Jan 2000 16:23:36   dcg
CPVCS    Initial revision.
CPVCS
CPVCS       Rev 1.3   Fri Jul 23 09:13:46 1999   dcg
CPVCS    removed unused code
CPVCS
CPVCS       Rev 1.2   Mon Sep 21 16:50:36 1998   dcg
CPVCS    replace single precision constants
CPVCS
CPVCS       Rev 1.1   Mon Apr 14 16:44:40 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.0   Mon Mar 18 11:21:58 1996   dcg
CPVCS    Initial revision.
C
C#######################################################################
C
      implicit real*8 (a-h, o-z)
      character*32 geom_name
C
      character*132 logmess
      include 'chydro.h'
      include 'consts.h'
      include 'geom_lg.h'
C
C#######################################################################
C
      integer nwds, imsgin(nwds), msgtype(nwds)
      real*8 xmsgin(nwds)
      character*(*) cmsgin(nwds)
C
      integer ierror
C
C#######################################################################
C
      pointer (ipisetwd, isetwd)
      pointer (ipimt1, imt1)
      pointer (ipitp1, itp1)
      pointer (ipicr1, icr1)
      pointer (ipisn1, isn1)
      pointer (ipxic, xic)
      pointer (ipyic, yic)
      pointer (ipzic, zic)
      integer isetwd(1000000)
      integer imt1(1000000), itp1(1000000),
     *        icr1(1000000), isn1(1000000)
      dimension xic(1000000), yic(1000000), zic(1000000)
      pointer (ipitetclr, itetclr(1000000))
      pointer (ipitet, itet(4,1000000))
      pointer (ipjtet, jtet(4,1000000))
      pointer (ipitet, itet1(4*1000000))
      pointer (ipjtet, jtet1(4*1000000))
C
C
C#######################################################################
C
      pointer (iprsplic , rsplic(1000000))
      pointer (ipvolic  , volic(1000000))
      pointer (ipxopic  , xopic(1000000))
      pointer (ippbtic  , pbtic(1000000))
      pointer (ippric   , pric(1000000))
      pointer (iptric   , tric(1000000))
      pointer (ippbiic  , pbiic(1000000))
      pointer (ipyldic  , yldic(1000000))
      pointer (ipgic    , gic(1000000))
      pointer (ipetotic , etotic(1000000))
      pointer (ipdedmric, dedmric(1000000))
      pointer (ipcsqic  , csqic(1000000))
      pointer (ipepsic  , epsic(1000000))
      pointer (iptic    , tic(1000000))
      pointer (ipxmic   , xmic(1000000))
C
C#######################################################################
C
      character*32  caraynam(8)
C
      pointer       (ipitest , itest(1)  )
      pointer       (ipmaspnt, imaspnt(1))
C
      pointer       (ipedtx  , edtx(1)   )
      pointer       (iptmpedt, tmpedt(8,1))
      pointer       (ipctmpedt, ctmpedt(8,1))
C
      pointer       (ipmpary , mpary(1) )
      pointer   (ipvels,vels)
      pointer   (ipdens,dens)
      pointer   (ippres,pres)
      pointer   (ipener,ener)
      real*8 vels(3,1000000),dens(1000000),pres(1000000),ener(1000000)
      logical ifvel,ifpres,ifdens,ifener
C
      character*32 isubname, cmo, iprtname, iblknam, iprtnam
      character*32 iopt
      character*32 ich1,ich2,ich3, cvelnm, cpresnm, cdensnm, cenernm
      character*8 ctmpedt, cpart
      real*8 alargenumber,asmallnumber
      data alargenumber,asmallnumber/1.0d+100,1.0d-200/

C
C#######################################################################
C
C
C
      cpart='part'
      isubname='edit'
      call cmo_get_name(cmo,ierror)
C
      call cmo_get_info('nnodes',cmo,nnodes,length,icmotype,ierror)
      call cmo_get_info('nelements',cmo,nelements,length,icmotype,ier)
      call cmo_get_info('mbndry',cmo,mbndry,length,icmotype,ierror)
C
      call cmo_get_info('isetwd',cmo,ipisetwd,lenisetwd,icmotype,ier)
      call cmo_get_info('imt1',cmo,ipimt1,length,icmotype,ierror)
      call cmo_get_info('itp1',cmo,ipitp1,length,icmotype,ierror)
      call cmo_get_info('icr1',cmo,ipicr1,length,icmotype,ierror)
      call cmo_get_info('isn1',cmo,ipisn1,length,icmotype,ierror)
      call cmo_get_info('xic',cmo,ipxic,length,icmotype,ierror)
      call cmo_get_info('yic',cmo,ipyic,length,icmotype,ierror)
      call cmo_get_info('zic',cmo,ipzic,length,icmotype,ierror)
      call cmo_get_info('itetclr',cmo,ipitetclr,length,icmotype,ier)
      call cmo_get_info('itet',cmo,ipitet,length,icmotype,ierror)
      call cmo_get_info('jtet',cmo,ipjtet,length,icmotype,ierror)
      ifvel=.true.
      ifpres=.true.
      ifdens=.true.
      ifener=.true.
      call cmo_get_attinfo('velname',cmo,iout,rout,cvelnm,
     *                        ipout,lout,itype,ierror_return)
      call cmo_get_info(cvelnm,cmo,ipvels,ilen,icmotype,ier)
      if (ier.ne.0) ifvel=.false.
      call cmo_get_attinfo('presname',cmo,iout,rout,cpresnm,
     *                        ipout,lout,itype,ierror_return)
      call cmo_get_info(cpresnm,cmo,ippres,ilen,icmotype,ier)
      if (ier.ne.0) ifpres=.false.
      call cmo_get_attinfo('densname',cmo,iout,rout,cdensnm,
     *                        ipout,lout,itype,ierror_return)
      call cmo_get_info(cdensnm,cmo,ipdens,ilen,icmotype,ier)
      if (ier.ne.0) ifdens=.false.
      call cmo_get_attinfo('enername',cmo,iout,rout,cenernm,
     *                        ipout,lout,itype,ierror_return)
      call cmo_get_info(cenernm,cmo,ipener,ilen,icmotype,ier)
         if (ier.ne.0) ifener=.false.

C
C
C
      length=nnodes
      call mmgetblk('volic',isubname,ipvolic,length,2,icscode)
      voltot=0.0
      do it=1,nelements
         i1=itet(1,it)
         i2=itet(2,it)
         i3=itet(3,it)
         i4=itet(4,it)
         x1=xic(i1)
         y1=yic(i1)
         z1=zic(i1)
         x2=xic(i2)
         y2=yic(i2)
         z2=zic(i2)
         x3=xic(i3)
         y3=yic(i3)
         z3=zic(i3)
         x4=xic(i4)
         y4=yic(i4)
         z4=zic(i4)
         dx=  (y2-y3)*(z4-z3)-(y4-y3)*(z2-z3)
         dy=-((x2-x3)*(z4-z3)-(x4-x3)*(z2-z3))
         dz=  (x2-x3)*(y4-y3)-(x4-x3)*(y2-y3)
         voltet=-((x3-x1)*dx+(y3-y1)*dy+(z3-y1)*dz) / 6.0
         volic(i1)=volic(i1)+voltet/4.0
         volic(i2)=volic(i2)+voltet/4.0
         volic(i3)=volic(i3)+voltet/4.0
         volic(i4)=volic(i4)+voltet/4.0
      enddo
C
      iprsplic = ippres
      ipxopic  = ippres
      ippbtic  = ippres
      ippric   = ippres
      iptric   = ippres
      ippbiic  = ippres
      ipyldic  = ippres
      ipgic    = ippres
      ipetotic = ippres
      ipdedmric= ippres
      ipcsqic  = ippres
      ipepsic  = ippres
      iptic    = ippres
      ipxmic   = ippres

C
C  ************************************************************
C
C     PRINT OUT HEADING FOR EDIT.
C
      write(logmess,9006) time
 9006 format(' Edit at ',1pe14.7)
      call writloga('default',2,logmess,1,ierrdum)
C
C     ******************************************************************
C
C     SET THE POINT INDEX BOUNDARIES.
C
      iopt = cmsgin(2)
C        **OPTION
C
C
C     ..................................................................
C     CHECK TO POINT LIMITS AND TRANSLATE THEM TO VALID LIMITS IF
C     NECESSARY.
C
C
C     CALL PNTLIMN TO SET POINT LIMITS.
C
      length = nnodes
      call mmgetblk('mpary',isubname,ipmpary,length,2,icscode)
C
C
C    set the point index boundaries
C
      ich1=' '
      ich2=' '
      ich3=' '
      if(msgtype(3).eq.1) then
         ipt1=imsgin(3)
         ipt2=imsgin(4)
         ipt3=imsgin(5)
c        ich1 = ipt1
         inpt2 = ipt2
         inpt3 = ipt3
C           **INCREMENT BETWEEN POINTS
         if (nwds .lt. 3) ipt1 = 0
         if (nwds .lt. 4) ipt2 = ipt1
         if (nwds .lt. 5) ipt3 = 1
         if (ipt1 .le. 0) ipt1 = 1
         if (ipt2 .le. 0) ipt2 = nnodes
         if (ipt3 .le. 0) ipt3 = 1
         if(ipt2.lt.ipt1) ipt2 = ipt1+ipt2
         ipt2 = min(ipt2,nnodes)
         if (iopt(1:icharlnf(iopt)) .eq. 'two') ipt3 = ipt2-ipt1
         call pntlimn(ipt1,ipt2,ipt3,ipmpary,mpno,nnodes,isetwd,itp1)
      else
        ich1=cmsgin(3)
        ich2=cmsgin(4)
        ich3=cmsgin(5)
        call pntlimc(ich1,ich2,ich3,ipmpary,mpno,nnodes,isetwd,itp1)
      endif
C
C     ******************************************************************
C
C     CHECK FOR REQUESTED MATERIAL IN COMMAND.
C
      iprtindx = 0
      if (nwds .gt. 5) then
         if (msgtype(6) .eq. 1) then
            iprtindx = imsgin(6)
         elseif (msgtype(6) .eq. 2) then
            iprtindx = int(xmsgin(6))
         else
            iprtname = cmsgin(6)
            ierrdum = 0
            call get_material_number(iprtname,iprtindx,ierrdum)
            if (ierrdum .ne. 0) iprtindx = 0
         endif
      endif
C
C     ******************************************************************
C
C     ADJUST DYNAMIC MEMORY.
C
      len1 = nnodes
      len2 = nnodes
      call mmgetblk('itp1',isubname,ipitp,len1,2,ics)
      call mmgetblk('itest',isubname,ipitest,len2,2,ics)
      call mmgetblk('imaspnt',isubname,ipmaspnt,len2,2,ics)
C
C     ******************************************************************
C

C     SQUEEZE OUT INACTIVE POINTS.
C
      do 100 masspt = 1,nnodes
         itest(masspt) = masspt
         imaspnt(masspt) = masspt
  100 continue
      do 110 ii = 1,mpno
         masspt = mpary(ii)
         itest(masspt) = cvmgt(0,itest(masspt),(itp1(masspt) .ge.
     *                   ifitpst1 .and. itp1(masspt) .le. ifitpen1) .or.
     *                   (itp1(masspt) .ge. ifitpst2 .and. itp1(masspt)
     *                   .le. ifitpen2))
  110 continue
      if (iprtindx .ne. 0) then
         do 115 ii = 1,mpno
            masspt = mpary(ii)
            itest(masspt) = cvmgt(itest(masspt),masspt,imt1(masspt) .eq.
     *                            iprtindx)
  115    continue
      endif
      call kmprsz(nnodes,itest,1,imaspnt,1,imaspnt,1,nmaspnt)
      if (mpno .eq. 0) nmaspnt = 0
      if (nmaspnt .le. 0) then
         if (ich1.eq.'pset' .or. ich1.eq.'pstatus') then
            write(logmess,9000) ich1,inpt2,inpt3
 9000       format(' No points that qualify: ',3a8)
          else
            write(logmess,9001) ipt1,ipt2,ipt3
 9001       format(' No points that qualify: ',3i6)
         endif
         call writloga('default',1,logmess,1,ierr)
         go to 9998
      endif
C
C     ******************************************************************
C
C     COMPUTE NUMBER OF MATERIAL REGIONS.
C
      numpart = 0
      do 120 masspt = 1,nmaspnt
         numpart = max0(numpart,imt1(imaspnt(masspt)))
  120 continue
      numpart = max0(numpart,iprtindx,1)
C
C     ******************************************************************
C
C     SET BOUNDS FOR LOOPS OVER MATERIAL NUMBERS.
C
      if (iprtindx .ne. 0) then
         kpart1 = iprtindx
         kpart2 = kpart1
      else
         kpart1 = 1
         kpart2 = numpart
      endif
C
C     ******************************************************************
C
C     PREPARE AND PRINT EDITS.
C
      leniopt=icharlnf(iopt)
      if (iopt(1:leniopt) .eq. 'parts') then
C
C        _______________________________________________________________
C
C        EDIT LIST OF MATERIAL REGIONS.
C
         icount = 0
         istart = imaspnt(1)
         imtsav = imt1(istart)
         do 300 masspt = 1,nmaspnt
            i1 = imaspnt(masspt)
            if (i1 .eq. imaspnt(1)) then
               icount = icount+1
               iend = i1
            elseif (imt1(i1) .eq. imt1(imaspnt(masspt-1))) then
               icount = icount+1
               iend = i1
            else
               call mmfindbk('cmregs',geom_name,ipcmregs,len,icscode)
               geom_name=current_geom_name
               iprtname=cmregs(imtsav)
               write(logmess,9510) imtsav,iprtname,icount,istart,iend
               if (icount .gt. 0)
     *            call writloga('default',0,logmess,0,ierr)
 9510          format('imt= ',i5,' name= ',a8,' count= ',i7,
     *                '  start=',i7,'  end=',i7)
               icount = 1
               istart = i1
               imtsav = imt1(istart)
            endif
 300     continue
         if (icount .gt. 0) then
            call mmfindbk('cmregs',geom_name,ipcmregs,len,icscode)
            geom_name=current_geom_name
            iprtname=cmregs(imtsav)
            write(logmess,9510) imtsav,iprtname,icount,istart,iend
            call writloga('default',0,logmess,0,ierr)
         endif
C
C        _______________________________________________________________
C
      elseif (iopt(1:leniopt) .eq. 'angular') then
C
C        _______________________________________________________________
C
C        EDIT OF ANGULAR MOMENTUM FOR SET OF POINTS.
C
         xcen = xmsgin(7)
         ycen = xmsgin(8)
         zcen = xmsgin(9)
         icount = 0
         xangular = 0.0
         do 200 masspt = 1,nmaspnt
            i1 = imaspnt(masspt)
            icount = icount+1
            vel=0.
            if(ifvel)vel=sqrt(vels(1,i1)**2+vels(2,i1)**2+vels(3,i1)**2)
            rad = sqrt((xic(i1)-xcen)**2 + (yic(i1)-ycen)**2 +
     *                (zic(i1)-zcen)**2 )
            xangular = xangular+rad*vel
 200     continue
         write(logmess,9500) icount,xangular
         call writloga('default',0,logmess,0,ierr)
 9500    format('number of points: ',i8,'  angular momentum: ',1pe15.8)
C
C        _______________________________________________________________
C
      elseif (iopt(1:leniopt) .eq. 'radial') then
C
C        _______________________________________________________________
C
C        EDIT OF RADIAL POSITIONS AND VELOCITIES FOR SET OF POINTS.
C
         write(logmess,9600)
 9600    format(8x,'ipt',7x,'R ',14x,'QR')
         call writloga('default',1,logmess,1,ierr)
         xcen = xmsgin(7)
         ycen = xmsgin(8)
         zcen = xmsgin(9)
         do 600 masspt = 1,nmaspnt
            i1 = imaspnt(masspt)
            radx = xic(i1)-xcen
            rady = yic(i1)-ycen
            radz = zic(i1)-zcen
            rad = sqrt(radx**2+rady**2+radz**2)
            if(ifvel) then
               velrad=(vels(1,i1)*radx+vels(2,i1)*rady+vels(3,i1)*radz)
     *          /(rad+epsilon)
            else
               velrad=0
            endif
            write(logmess,9610) i1,rad,velrad
 9610       format(1x,i10,1p2e16.7)
            call writloga('default',0,logmess,0,ierr)
  600    continue
C
C        _______________________________________________________________
C
      elseif (iopt(1:leniopt) .eq. 'points') then
C
C        _______________________________________________________________
C
C        PRINT OUT VALUES OF SPECIFIED ARRAY FOR SET OF POINTS.
C
         call mmgetblk('tmpedt',isubname,iptmpedt,8*nmaspnt,2,
     *                 icscode)
         call mmgetblk('ctmpedt',isubname,ipctmpedt,8*32*nmaspnt,2,
     *                 icscode)
         naray = 4
         do 500 masspt = 1,nmaspnt
            i1 = imaspnt(masspt)
            tmpedt(1,masspt) = imt1(i1)
            tmpedt(2,masspt) = itp1(i1)
            tmpedt(3,masspt) = icr1(i1)
            iep = 0
            isp = 0
            mlt = 0
C*****      iep = and(shiftr(ifitwc(i1),ifwshf(ifieppos)),1b)
C*****      isp = and(shiftr(ifitwc(i1),ifwshf(ifisppos)),1b)
C*****      mlt = and(shiftr(ifitwc(i1),ifwshf(ifmltpos)),1b)
            ctmpedt(4,masspt) = '    e   '
            if (iep .eq. 1) ctmpedt(4,masspt) = '    p   '
            if (isp .eq. 1) ctmpedt(4,masspt) = '    s   '
            if (mlt .eq. 1) ctmpedt(4,masspt) = '    m   '
  500    continue
         do 510 iaray = 6,9
            caraynam(iaray) = ' '
            if (nwds .gt. iaray) caraynam(iaray) = cmsgin(1+iaray)
            ipedtx = 0
            iprtnam=cmo
            iblknam=caraynam(iaray)
            call mmgetpr(iblknam,iprtnam,ipedtx,ierr)
            if (ierr .eq. 0) then
               naray = naray+1
               caraynam(naray) = caraynam(iaray)
               do 515 masspt = 1,nmaspnt
                  tmpedt(naray,masspt) = edtx(imaspnt(masspt))
  515          continue
            endif
  510    continue
         if (naray .gt. 4) then
            write(logmess,9520) (caraynam(iaray),iaray = 5,naray)
 9520       format(8x,'ipt',' imt',' itp',' icr',' state',4(4x,a8))
            call writloga('default',1,logmess,1,ierrdum)
            do 520 masspt = 1,nmaspnt
               i1 = imaspnt(masspt)
            write(logmess,9521)i1,(nint(tmpedt(iaray,masspt)),iaray=1,3)
     *         ,ctmpedt(4,masspt),(tmpedt(iaray,masspt),iaray=5,naray)
 9521          format(1x,i10,3i4,a6,1p4e12.4)
               call writloga('default',0,logmess,0,ierrdum)
  520       continue
         else
            write(logmess,9522)
 9522       format(8x,'ipt',' imt',' itp',' icr',' state')
            call writloga('default',1,logmess,1,ierrdum)
            do 525 masspt = 1,nmaspnt
               i1 = imaspnt(masspt)
               write(logmess,9523) i1,
     *            (nint(tmpedt(iaray,masspt)),iaray=1,3),
     *            ctmpedt(4,masspt)
 9523          format(1x,i10,3i4,a6)
               call writloga('default',0,logmess,0,ierrdum)
  525       continue
         endif
         call mmrelblk('tmpedt',isubname,ipctmpedt,icscode)
      else
C
C        _______________________________________________________________
C
C        EDIT OF SUMS AND AVERAGES --- ACCUMULATE DATA.
C
         xtot = 0.0
         ytot = 0.0
         ztot = 0.0
         utot = 0.0
         vtot = 0.0
         wtot = 0.0
         ptot = 0.0
         rtot = 0.0
         rsptot = 0.0
         etot = 0.0
         ttot = 0.0
         trtot = 0.0
         prtot = 0.0
         xoptot = 0.0
         xmtot = 0.0
         voltot = 0.0
         csqtot = 0.0
         ettot = 0.0
         dedmrtot = 0.0
         pbttot = 0.0
         pbitot = 0.0
         gtot = 0.0
         yldtot = 0.0
         epstot = 0.0
C
         xavg = 0.0
         yavg = 0.0
         zavg = 0.0
         uavg = 0.0
         vavg = 0.0
         wavg = 0.0
         pavg = 0.0
         ravg = 0.0
         rspavg = 0.0
         eavg = 0.0
         tavg = 0.0
         travg = 0.0
         pravg = 0.0
         xopavg = 0.0
         xmavg = 0.0
         volavg = 0.0
         csqavg = 0.0
         etavg = 0.0
         pbtavg = 0.0
         pbiavg = 0.0
         gavg = 0.0
         yldavg = 0.0
         epsavg = 0.0
C
         x1max = -alargenumber
         y1max = -alargenumber
         z1max = -alargenumber
         u1max = -alargenumber
         v1max = -alargenumber
         w1max = -alargenumber
         p1max = -alargenumber
         r1max = -alargenumber
         rsp1max = -alargenumber
         e1max = -alargenumber
         t1max = -alargenumber
         tr1max = -alargenumber
         pr1max = -alargenumber
         xop1max = -alargenumber
         xm1max = -alargenumber
         vol1max = -alargenumber
         csq1max = -alargenumber
         et1max = -alargenumber
         ded1max = -alargenumber
         pbt1max = -alargenumber
         pbi1max = -alargenumber
         g1max = -alargenumber
         yld1max = -alargenumber
         eps1max = -alargenumber
C
         x1min = alargenumber
         y1min = alargenumber
         z1min = alargenumber
         u1min = alargenumber
         v1min = alargenumber
         w1min = alargenumber
         p1min = alargenumber
         r1min = alargenumber
         rsp1min = alargenumber
         e1min = alargenumber
         t1min = alargenumber
         tr1min = alargenumber
         pr1min = alargenumber
         xop1min = alargenumber
         xm1min = alargenumber
         vol1min = alargenumber
         csq1min = alargenumber
         et1min = alargenumber
         ded1min = alargenumber
         pbt1min = alargenumber
         pbi1min = alargenumber
         g1min = alargenumber
         yld1min = alargenumber
         eps1min = alargenumber
C
         ix1max = 0
         iy1max = 0
         iz1max = 0
         iu1max = 0
         iv1max = 0
         iw1max = 0
         ip1max = 0
         ir1max = 0
         irsp1max = 0
         ie1max = 0
         it1max = 0
         itr1max = 0
         ipr1max = 0
         ixop1max = 0
         ixm1max = 0
         ivol1max = 0
         icsq1max = 0
         iet1max = 0
         ided1max = 0
         ipbt1max = 0
         ipbi1max = 0
         ig1max = 0
         iyld1max = 0
         ieps1max = 0
C
         ix1min = 0
         iy1min = 0
         iz1min = 0
         iu1min = 0
         iv1min = 0
         iw1min = 0
         ip1min = 0
         ir1min = 0
         irsp1min = 0
         ie1min = 0
         it1min = 0
         itr1min = 0
         ipr1min = 0
         ixop1min = 0
         ixm1min = 0
         ivol1min = 0
         icsq1min = 0
         iet1min = 0
         ided1min = 0
         ipbt1min = 0
         ipbi1min = 0
         ig1min = 0
         iyld1min = 0
         ieps1min = 0
C
         ipts = 0
         do 130 i = 1,nmaspnt
            i1 = imaspnt(i)
            ipts = ipts+1
            xtot = xtot+xic(i1)
            ytot = ytot+yic(i1)
            ztot = ztot+zic(i1)
            if (ifvel) then
               utot = utot+vels(1,i1)
               vtot = vtot+vels(2,i1)
               wtot = wtot+vels(3,i1)
            endif
            if(ifpres.and.ifdens.and.ifener) then
               ptot = ptot+pres(i1)
               rtot = rtot+dens(i1)
               rsptot = rsptot+rsplic(i1)
               etot = etot+ener(i1)
               ttot = ttot+tic(i1)
               trtot = trtot+tric(i1)
               prtot = prtot+pric(i1)
               xoptot = xoptot+xopic(i1)
               xmtot = xmtot+xmic(i1)
               voltot = voltot+volic(i1)
               csqtot = csqtot+csqic(i1)
               ettot = ettot+etotic(i1)
               dedmrtot = dedmrtot+dedmric(i1)
               pbttot = pbttot+pbtic(i1)
               pbitot = pbitot+pbiic(i1)
               gtot = gtot+gic(i1)
               yldtot = yldtot+yldic(i1)
               epstot = epstot+epsic(i1)
            endif
C
            if (xic(i1) .gt. x1max) then
               x1max = xic(i1)
               ix1max = i1
            endif
            if (yic(i1) .gt. y1max) then
               y1max = yic(i1)
               iy1max = i1
            endif
            if (zic(i1) .gt. z1max) then
               z1max = zic(i1)
               iz1max = i1
            endif
            if(ifvel) then
               if (vels(1,i1) .gt. u1max) then
                  u1max = vels(1,i1)
                  iu1max = i1
               endif
               if (vels(2,i1) .gt. v1max) then
                  v1max = vels(2,i1)
                  iv1max = i1
               endif
               if (vels(3,i1) .gt. w1max) then
                  w1max = vels(3,i1)
                  iw1max = i1
               endif
            endif
            if (ifpres.and.ifdens.and.ifener) then
               if (pres(i1) .gt. p1max) then
                  p1max = pres(i1)
                  ip1max = i1
               endif
               if (dens(i1) .gt. r1max) then
                  r1max = dens(i1)
                  ir1max = i1
               endif
               if (rsplic(i1) .gt. rsp1max) then
                  rsp1max = rsplic(i1)
                  irsp1max = i1
               endif
               if (ener(i1) .gt. e1max) then
                  e1max = ener(i1)
                  ie1max = i1
               endif
               if (tic(i1) .gt. t1max) then
                  t1max = tic(i1)
                  it1max = i1
               endif
               if (tric(i1) .gt. tr1max) then
                  tr1max = tric(i1)
                  itr1max = i1
               endif
               if (pric(i1) .gt. pr1max) then
                  pr1max = pric(i1)
                  ipr1max = i1
               endif
               if (xopic(i1) .gt. xop1max) then
                  xop1max = xopic(i1)
                  ixop1max = i1
               endif
               if (xmic(i1) .gt. xm1max) then
                  xm1max = xmic(i1)
                  ixm1max = i1
               endif
               if (volic(i1) .gt. vol1max) then
                  vol1max = volic(i1)
                  ivol1max = i1
               endif
               if (csqic(i1) .gt. csq1max) then
                  csq1max = csqic(i1)
                  icsq1max = i1
               endif
               if (etotic(i1) .gt. et1max) then
                  et1max = etotic(i1)
                  iet1max = i1
               endif
               if (dedmric(i1) .gt. ded1max) then
                  ded1max = dedmric(i1)
                  ided1max = i1
               endif
               if (pbtic(i1) .gt. pbt1max) then
                  pbt1max = pbtic(i1)
                  ipbt1max = i1
               endif
               if (pbiic(i1) .gt. pbi1max) then
                  pbi1max = pbiic(i1)
                  ipbi1max = i1
               endif
               if (gic(i1) .gt. g1max) then
                  g1max = gic(i1)
                  ig1max = i1
               endif
               if (yldic(i1) .gt. yld1max) then
                  yld1max = yldic(i1)
                  iyld1max = i1
               endif
               if (epsic(i1) .gt. eps1max) then
                  eps1max = epsic(i1)
                  ieps1max = i1
               endif
            endif
C
            if (xic(i1) .lt. x1min) then
               x1min = xic(i1)
               ix1min = i1
            endif
            if (yic(i1) .lt. y1min) then
               y1min = yic(i1)
               iy1min = i1
            endif
            if (zic(i1) .lt. z1min) then
               z1min = zic(i1)
               iz1min = i1
            endif
           if (ifvel) then
               if (vels(1,i1) .lt. u1min) then
                  u1min = vels(1,i1)
                  iu1min = i1
               endif
               if (vels(2,i1) .lt. v1min) then
                  v1min = vels(2,i1)
                  iv1min = i1
               endif
               if (vels(3,i1) .lt. w1min) then
                  w1min = vels(3,i1)
                  iw1min = i1
               endif
            endif
            if (ifpres.and.ifdens. and. ifener) then
               if (pres(i1) .lt. p1min) then
                  p1min = pres(i1)
                  ip1min = i1
               endif
               if (dens(i1) .lt. r1min) then
                  r1min = dens(i1)
                  ir1min = i1
               endif
               if (rsplic(i1) .lt. rsp1min) then
                  rsp1min = rsplic(i1)
                  irsp1min = i1
               endif
               if (ener(i1) .lt. e1min) then
                  e1min = ener(i1)
                  ie1min = i1
               endif
               if (tic(i1) .lt. t1min) then
                  t1min = tic(i1)
                  it1min = i1
               endif
               if (tric(i1) .lt. tr1min) then
                  tr1min = tric(i1)
                  itr1min = i1
               endif
               if (pric(i1) .lt. pr1min) then
                  pr1min = pric(i1)
                  ipr1min = i1
               endif
               if (xopic(i1) .lt. xop1min) then
                  xop1min = xopic(i1)
                  ixop1min = i1
               endif
               if (xmic(i1) .lt. xm1min) then
                  xm1min = xmic(i1)
                  ixm1min = i1
               endif
               if (volic(i1) .lt. vol1min) then
                  vol1min = volic(i1)
                  ivol1min = i1
               endif
               if (csqic(i1) .lt. csq1min) then
                  csq1min = csqic(i1)
                  icsq1min = i1
               endif
               if (etotic(i1) .lt. et1min) then
                  et1min = etotic(i1)
                  iet1min = i1
               endif
               if (dedmric(i1) .lt. ded1min) then
                  ded1min = dedmric(i1)
                  ided1min = i1
               endif
               if (pbtic(i1) .lt. pbt1min) then
                  pbt1min = pbtic(i1)
                  ipbt1min = i1
               endif
               if (pbiic(i1) .lt. pbi1min) then
                  pbi1min = pbiic(i1)
                  ipbi1min = i1
               endif
               if (gic(i1) .lt. g1min) then
                  g1min = gic(i1)
                  ig1min = i1
               endif
               if (yldic(i1) .lt. yld1min) then
                  yld1min = yldic(i1)
                  iyld1min = i1
               endif
               if (epsic(i1) .lt. eps1min) then
                  eps1min = epsic(i1)
                  ieps1min = i1
               endif
            endif
 130     continue
         if (ipts .gt. 0) then
            xavg = xtot/dble(ipts)
            yavg = ytot/dble(ipts)
            zavg = ztot/dble(ipts)
            uavg = utot/dble(ipts)
            vavg = vtot/dble(ipts)
            wavg = wtot/dble(ipts)
            pavg = ptot/dble(ipts)
            ravg = rtot/dble(ipts)
            rspavg = rsptot/dble(ipts)
            eavg = etot/dble(ipts)
            tavg = ttot/dble(ipts)
            travg = trtot/dble(ipts)
            pravg = prtot/dble(ipts)
            xopavg = xoptot/dble(ipts)
            xmavg = xmtot/dble(ipts)
            volavg = voltot/dble(ipts)
            csqavg = csqtot/dble(ipts)
            etavg = ettot/dble(ipts)
            dedmravg = dedmrtot/dble(ipts)
            pbtavg = pbttot/dble(ipts)
            pbiavg = pbitot/dble(ipts)
            gavg = gtot/dble(ipts)
            yldavg = yldtot/dble(ipts)
            epsavg = epstot/dble(ipts)
         endif
C
C        _______________________________________________________________
C
C        EDIT OF SUMS AND AVERAGES --- PRINT POINT INDEX BOUNDARIES.
C
         if (ich1.eq.'pset' .or. ich1.eq.'pstatus') then
            write(logmess,9010) ich1,ich2,ich3,ipts
 9010       format('Summary:   ',a8,2x,a8,2x,a8,'    tot=',i5)
          else
            write(logmess,9011) ipt1,ipt2,ipt3,ipts
 9011       format('Summary:   i=',i5,'   f=',i5,'   s=',i5,
     &             '    tot=',i5)
         endif
         call writloga('default',1,logmess,0,ierr)
C
C        _______________________________________________________________
C
C        EDIT OF AVERAGES, MAXIMA, AND MINIMA.
C
         write(logmess,9005) 'Variable','Minimum','Maximum','Average'
 9005    format(1x,a8,17x,a7,16x,a7,9x,a7)
         call writloga('default',1,logmess,1,ierr)
         write(logmess,9003) 'xic     ',ix1min,x1min,ix1max,x1max,xavg
 9003    format(1x,a8,1x,i7,2x,1pe14.7,i7,2x,1pe14.7,2x,1pe14.7)
         call writloga('default',0,logmess,0,ierr)
         write(logmess,9003) 'yic     ',iy1min,y1min,iy1max,y1max,yavg
         call writloga('default',0,logmess,0,ierr)
         write(logmess,9003) 'zic     ',iz1min,z1min,iz1max,z1max,zavg
         call writloga('default',0,logmess,0,ierr)
         write(logmess,9003) 'uic     ',iu1min,u1min,iu1max,u1max,uavg
         call writloga('default',1,logmess,0,ierr)
         write(logmess,9003) 'vic     ',iv1min,v1min,iv1max,v1max,vavg
         call writloga('default',0,logmess,0,ierr)
         write(logmess,9003) 'wic     ',iw1min,w1min,iw1max,w1max,wavg
         call writloga('default',0,logmess,0,ierr)
         write(logmess,9003) 'pres     ',ip1min,p1min,ip1max,p1max,pavg
         call writloga('default',1,logmess,0,ierr)
         write(logmess,9003) 'dens     ',ir1min,r1min,ir1max,r1max,ravg
         call writloga('default',0,logmess,0,ierr)
         write(logmess,9003) 'rsplic  ',irsp1min,rsp1min,
     *                       irsp1max,rsp1max,rspavg
         call writloga('default',0,logmess,0,ierr)
         write(logmess,9003) 'eic     ',ie1min,e1min,ie1max,e1max,eavg
         call writloga('default',1,logmess,0,ierr)
         write(logmess,9003) 'tic     ',it1min,t1min,it1max,t1max,tavg
         call writloga('default',0,logmess,0,ierr)
         write(logmess,9003) 'tric    ',itr1min,tr1min,
     *                       itr1max,tr1max,travg
         call writloga('default',0,logmess,0,ierr)
         write(logmess,9003) 'pric    ',ipr1min,pr1min,
     *                       ipr1max,pr1max,pravg
         call writloga('default',1,logmess,0,ierr)
         write(logmess,9003) 'xopic   ',ixop1min,xop1min,
     *                       ixop1max,xop1max,xopavg
         call writloga('default',0,logmess,0,ierr)
         write(logmess,9003) 'xmic    ',ixm1min,xm1min,
     *                       ixm1max,xm1max,xmavg
         call writloga('default',0,logmess,0,ierr)
         write(logmess,9003) 'volic   ',ivol1min,vol1min,
     *                       ivol1max,vol1max,volavg
         call writloga('default',1,logmess,0,ierr)
         write(logmess,9003) 'csqic   ',icsq1min,csq1min,
     *                       icsq1max,csq1max,csqavg
         call writloga('default',0,logmess,0,ierr)
         write(logmess,9003) 'etotic  ',iet1min,et1min,
     *                       iet1max,et1max,etavg
         call writloga('default',0,logmess,0,ierr)
         write(logmess,9003) 'pbtic   ',ipbt1min,pbt1min,
     *                       ipbt1max,pbt1max,pbtavg
         call writloga('default',1,logmess,0,ierr)
         write(logmess,9003) 'pbiic   ',ipbi1min,pbi1min,
     *                       ipbi1max,pbi1max,pbiavg
         call writloga('default',0,logmess,0,ierr)
         write(logmess,9003) 'dedmric ',ided1min,ded1min,
     *                       ided1max,ded1max,dedmravg
         call writloga('default',0,logmess,0,ierr)
         write(logmess,9003) 'gic     ',ig1min,g1min,ig1max,g1max,gavg
         call writloga('default',1,logmess,0,ierr)
         write(logmess,9003) 'yldic   ',iyld1min,yld1min,
     *                       iyld1max,yld1max,yldavg
         call writloga('default',0,logmess,0,ierr)
         write(logmess,9003) 'epsic   ',ieps1min,eps1min,
     *                       ieps1max,eps1max,epsavg
         call writloga('default',0,logmess,0,ierr)
C
C        _______________________________________________________________
C
      endif
C
C     ******************************************************************
C
C     RELEASE DYNAMIC MEMORY.
C
 9998 continue
      call mmrelprt(isubname,ics)
C
C     ******************************************************************
C
C     SET ERROR INDICATOR.
C
C
      ierr3=0
C
C     ******************************************************************
C
C     SET UP THE USUAL CFT IMMUNE STATEMENT 9999 IN CASE DDT IS NEEDED.
C
      goto 9999
 9999 continue
C
C     ******************************************************************
C
      return
      end

ext: f

max_forks_repo_name: daniellivingston/LaGriT


text:
The CoHo Bakery  (short for Coffee House Bakery) located in the Memorial Union sells Cookies, Pastries, and Baked Goods freshly baked goods, such as chocolate chip cookies, carrot cake, oatmeal raisin cookies, tatros, sugar cookies, bozo bars, berry streusel, strawberry and chocolate cake.

The Bakery also sells fruit, soda, ice cream, Odwalla, coffee, tea, and hot chocolate.  Its very important to note that they have a tradition of making coffee half off during finals.  They portray this as a way to help out those studying students who burn the midnight oil.

In the morning only, they serve croissants and muffins.

For more campus food options, see Campus Eats.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
C Copyright(C) 2009-2017 National Technology & Engineering Solutions of
C 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 Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions are
C met:
C
C     * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C     * Redistributions in binary form must reproduce the above
C       copyright notice, this list of conditions and the following
C       disclaimer in the documentation and/or other materials provided
C       with the distribution.
C     * Neither the name of NTESS nor the names of its
C       contributors may be used to endorse or promote products derived
C       from this software without specific prior written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

C $Log: grsdev.f,v $
C Revision 1.2  2009/03/25 12:36:44  gdsjaar
C Add copyright and license notice to all files.
C Permission to assert copyright has been granted; blot is now open source, BSD
C
C Revision 1.1  1994/04/07 20:02:44  gdsjaar
C Initial checkin of ACCESS/graphics/blotII2
C
c Revision 1.2  1990/12/14  08:51:52  gdsjaar
c Added RCS Id and Log to all files
c
C=======================================================================
      SUBROUTINE GRSDEV (INDEV)
C=======================================================================

C   --*** GRSDEV *** (GRPLIB) Select device
C   --   Written by Amy Gilkey, revised 08/24/87
C   --
C   --GRSDEV selects a device and changes all the device parameters.
C   --
C   --Parameters:
C   --   INDEV - IN - the device to be selected
C   --
C   --Common Variables:
C   --   Uses ICURDV, DEVOK, IFONT, NUMCOL of /GRPCOM/
C   --   Sets ICURDV of /GRPCOM/

C   --Routines Called:
C   --   GRCOLT - (GRPLIB) Set color table
C   --   GRFONT - (GRPLIB) Set font

      PARAMETER (KDVDI=10000)

      COMMON /GRPCOC/ DEVNAM(2), DEVCOD(2)
      CHARACTER*3 DEVNAM
      CHARACTER*8 DEVCOD
      COMMON /GRPCOM/ ICURDV, ISHARD, DEVOK(2), TALKOK(2),
     &   NSNAP(2), IFONT(2), SOFTCH(2), AUTOPL(2),
     &   MAXCOL(2), NUMCOL(0:1,2), MAPALT(2), MAPUSE(2)
      LOGICAL ISHARD, DEVOK, TALKOK, SOFTCH, AUTOPL

C   --If the device number is not given, choose the first available device
      IF ((INDEV .NE. 1) .AND. (INDEV .NE. 2)) THEN
         IF (DEVOK(1)) THEN
            IDEV = 1
         ELSE
            IDEV = 2
         END IF
      ELSE
         IDEV = INDEV
      END IF

C   --Skip if invalid parameter
      IF (.NOT. DEVOK(IDEV)) GOTO 100

C   --Skip if device already selected
      IF (IDEV .EQ. ICURDV) GOTO 100

C   --Turn off old device and turn on new device
      CALL VDESCP (KDVDI + IDEV, 0, 0)

      ICURDV = IDEV

C   --Set color table
      CALL GRCOLT

C   --Set font
      CALL GRFONT (IFONT(ICURDV))

C   --Set number of frames to snap
      CALL GRSNAP ('INIT', ICURDV)

C   --Set line widths
      CALL GRLWID

C   --Reset the single hardcopy flag if terminal device selected
      IF (ICURDV .EQ. 1) ISHARD = .FALSE.

  100 CONTINUE
      RETURN
      END

max_stars_repo_name: brian-kelley/seacas

max_issues_repo_name: brian-kelley/seacas

max_forks_repo_name: brian-kelley/seacas