text:
      SUBROUTINE ST_ETOA  ( barray, nchar, outstr, iret )
C************************************************************************
C* ST_ETOA								*
C*									*
C* This subroutine converts a character string in EBCDIC to a string	*
C* in ASCII.								*
C*									*
C* ST_ETOA  ( BARRAY, NCHAR, OUTSTR, IRET )				*
C*									*
C* Input parameters:							*
C*	BARRAY (NCHAR)	BYTE		EBCDIC characters		*
C*	NCHAR		INTEGER		Number of characters		*
C*									*
C* Output parameters:							*
C*	OUTSTR		CHAR*		ASCII string			*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* J. Fulson-Woytek/932	 4/88						*
C* M. desJardins/GSFC	12/90						*
C************************************************************************
	CHARACTER*(*)	outstr
	BYTE		barray (*)
C*
	INTEGER		itable (256)
C*
	DATA   ITABLE  /
     1	  0,001,002,003,  0,009,  0,127,  0,  0,  0,011,012,013,014,015,
     2	016,017,018,019,  0,  0,008,  0,024,025,  0,  0,028,029,030,031,
     3	  0,  0,028,  0,  0,010,023,027,  0,  0,  0,  0,  0,005,006,007,
     4	  0,  0,022,  0,  0,030,  0,004,  0,  0,  0,019,020,021,  0,026,
     5	032,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,046,060,040,043,124,
     6	038,  0,  0,  0,  0,  0,  0,  0,  0,  0,033,036,042,041,059,094,
     7	045,047,  0,  0,  0,  0,  0,  0,  0,  0,  0,044,037,095,062,063,
     8	  0,  0,  0,  0,  0,  0,  0,  0,  0,096,058,035,064,039,061,034,
     9	  0,097,098,099,100,101,102,103,104,105,  0,  0,  0,  0,  0,  0,
     A	  0,106,107,108,109,110,111,112,113,114,  0,  0,  0,  0,  0,  0,
     B	  0,126,115,116,117,118,119,120,121,122,  0,  0,  0,091,  0,  0,
     C	  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,093,  0,  0,
     D	123,065,066,067,068,069,070,071,072,073,  0,  0,  0,  0,  0,  0,
     E	125,074,075,076,077,078,079,080,081,082,  0,  0,  0,  0,  0,  0,
     F	092,  0,083,084,085,086,087,088,089,090,  0,  0,  0,  0,  0,  0,
     G	048,049,050,051,052,053,054,055,056,057,124,  0,  0,  0,  0,  0/
C------------------------------------------------------------------------
	iret = 0
C
C*	Convert one character at a time.
C
	DO  i = 1, nchar
	    n = barray (i)
	    IF  ( n .lt. 0 )  n = n + 256
	    m = itable (n + 1)
	    outstr (i:i) = CHAR ( m )
	END DO
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


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

!	parallel do with block scheduling

	program p
	 implicit none
	 integer n
	 parameter(n=10)
	 integer a(n)
	 integer result(n)
	 integer expect(n)
	 integer expect2(n)
	 data expect /0,0,0,1,1,1,2,2,3,3/	! pgf90
	 data expect2/0,0,1,1,2,2,3,3,3,3/	! pgf77
	 integer chkalt
	 integer i,k
	 do i = 1,n
	  a(i) = -1
	 enddo
	 call sp2(a,n)
	 do i = 1,n
	  result(i) = a(i)
	 enddo
	 if (chkalt(result, expect, n) .eq. 1) then
	     call check(result,expect,n)
	 else
	     call check(result,expect2,n)
	 endif
	end

!pgi$G -y 69 4
	subroutine sp2(a,n)
	 implicit none
	 integer n
	 integer a(n)
	 integer iam, i, omp_get_thread_num
!$omp    parallel private(iam)
	  iam = omp_get_thread_num()
!$omp	  do schedule(static)
	  ! block scheduling
	   do i = 1,n
	    a(i) = iam
	   enddo
!$omp    end parallel
	end

ext: f

max_stars_repo_name: abrahamtovarmob/flang

max_issues_repo_name: abrahamtovarmob/flang

max_forks_repo_name: abrahamtovarmob/flang


text:
Selby is a second year Computer Science major.  She also loves playing world of warcraft and working out.

20061019 21:32:17 nbsp Yay! Selby is on the wiki! :) Users/WilliamLewis

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
module contiguous_ring_array_descriptor_module
    use, intrinsic :: iso_fortran_env, only : int64

    implicit none
    private

    public :: contiguous_ring_array_descriptor

    type :: contiguous_ring_array_descriptor
        integer(int64) :: array_size, current_offset, elements_in_use, total_size
        integer(int64) :: available_size
    contains
        procedure :: get_array_index => get_array_index
        procedure :: get_next_index => get_next_index
        procedure :: get_available_size => get_available_size
        generic :: increase => increase_int64, increase_int32
        generic :: decrease => decrease_int32, decrease_int64
        procedure :: increase_int32 => increase_int32
        procedure :: increase_int64 => increase_int64
        procedure :: decrease_int32 => decrease_int32
        procedure :: decrease_int64 => decrease_int64
        procedure :: reset => reset
        procedure :: cleanup => cleanup
        procedure :: clear => clear
        procedure :: is_valid => is_valid
        procedure :: truncate_array_size => truncate_array_size
        procedure :: restore_array_size => restore_array_size
        procedure :: update_available_size => update_available_size
    end type contiguous_ring_array_descriptor

    interface contiguous_ring_array_descriptor
        module procedure constructor_empty
        module procedure constructor
        module procedure constructor_int32
    end interface contiguous_ring_array_descriptor

contains
    function constructor_empty() result(this)
        type(contiguous_ring_array_descriptor) :: this

        call this%clear()
    end function constructor_empty

    function constructor_int32(total_size) result(this)
        integer, intent(in) :: total_size
        type(contiguous_ring_array_descriptor) :: this

        this = contiguous_ring_array_descriptor(int(total_size, int64))
    end function constructor_int32

    function constructor(total_size) result(this)
        integer(int64), intent(in) :: total_size
        type(contiguous_ring_array_descriptor) :: this

        this = contiguous_ring_array_descriptor()
        this%total_size = total_size
        call this%reset()
    end function constructor

    integer(int64) function get_array_index(this, idx)
        class(contiguous_ring_array_descriptor), intent(in) :: this
        integer(int64), intent(in) :: idx

        get_array_index = -1
        if ( this%is_valid() ) &
                get_array_index = mod(this%current_offset+idx-1, this%array_size) + 1
    end function get_array_index

    integer(int64) function get_next_index(this)
        class(contiguous_ring_array_descriptor), intent(in) :: this

        get_next_index = this%get_array_index(this%elements_in_use+1)
    end function get_next_index

    integer(int64) function get_available_size(this)
        class(contiguous_ring_array_descriptor), intent(in) :: this

        get_available_size = this%available_size
    end function get_available_size

    subroutine reset(this)
        class(contiguous_ring_array_descriptor), intent(inout) :: this

        this%current_offset = 0
        this%elements_in_use = 0
        this%array_size = this%total_size
        this%available_size = this%array_size
    end subroutine reset

    logical function is_valid(this)
        class(contiguous_ring_array_descriptor), intent(in) :: this

        is_valid = this%array_size > 0 .and. &
                this%elements_in_use <= this%array_size .and. &
                this%elements_in_use >= 0
    end function is_valid

    subroutine increase_int32(this, increase_by)
        class(contiguous_ring_array_descriptor), intent(inout) :: this
        integer, intent(in) :: increase_by

        call this%increase(int(increase_by, int64))
    end subroutine increase_int32

    subroutine increase_int64(this, increase_by)
        class(contiguous_ring_array_descriptor), intent(inout) :: this
        integer(int64), intent(in) :: increase_by

        call this%truncate_array_size(increase_by)

        this%elements_in_use = this%elements_in_use + increase_by
        call this%update_available_size()

        if ( .not. this%is_valid() ) &
                error stop "contiguous_ring_array_descriptor:increase:Request to large."
    end subroutine increase_int64

    subroutine truncate_array_size(this, increase_by)
        class(contiguous_ring_array_descriptor), intent(inout) :: this
        integer(int64), intent(in) :: increase_by

        integer(int64) :: last, next

        next = this%get_next_index()
        last = next - 1
        if ( next > this%current_offset .and. &
                last + increase_by > this%array_size ) then
            this%array_size = last
            this%current_offset = mod(this%current_offset, this%array_size)
        end if
    end subroutine truncate_array_size

    subroutine decrease_int32(this, decrease_by)
        class(contiguous_ring_array_descriptor), intent(inout) :: this
        integer, intent(in) :: decrease_by

        call this%decrease(int(decrease_by, int64))
    end subroutine decrease_int32

    subroutine decrease_int64(this, decrease_by)
        class(contiguous_ring_array_descriptor), intent(inout) :: this
        integer(int64), intent(in) :: decrease_by

        this%elements_in_use = this%elements_in_use - decrease_by
        this%current_offset = mod(this%current_offset + decrease_by, this%array_size)

        call this%restore_array_size()
        if ( this%elements_in_use == 0 ) then
            call this%reset()
        else
            call this%update_available_size()
        end if

        if ( .not. this%is_valid() ) &
                error stop "contiguous_ring_array_descriptor:decrease:Request to large."
    end subroutine decrease_int64

    subroutine restore_array_size(this)
        class(contiguous_ring_array_descriptor), intent(inout) :: this

        if ( this%current_offset == 0 ) this%array_size = this%total_size
    end subroutine restore_array_size

    subroutine update_available_size(this)
        class(contiguous_ring_array_descriptor), intent(inout) :: this

        integer(int64) :: next

        next = this%get_next_index()

        if ( next > this%current_offset ) then
            this%available_size = max(this%array_size - next + 1, this%current_offset)
        else
            this%available_size = this%current_offset - next + 1
        end if
        if ( this%elements_in_use >= this%array_size .or. this%get_next_index() == -1 ) this%available_size = 0
    end subroutine update_available_size

    subroutine cleanup(this)
        class(contiguous_ring_array_descriptor), intent(inout) :: this

        call this%clear()
    end subroutine cleanup

    subroutine clear(this)
        class(contiguous_ring_array_descriptor), intent(inout) :: this

        this%total_size = 0
        call this%reset()
    end subroutine clear
end module contiguous_ring_array_descriptor_module

max_stars_repo_name: cheshyre/ntcl-data

max_issues_repo_name: cheshyre/ntcl-data

max_forks_repo_name: cheshyre/ntcl-data


text:
Nancy has two careers.

She is a Gold Certified Personal Fitness Trainer by the American Council on Exercise since 1990 with special recognition in Mind/ Body Integration. She is also a Medical Exercise Specialist certified by the American Academy of Health, Fitness and Rehabilitation Professionals. She is additionally certified in Advanced Pilates Mat by Powerhouse Pilates.

She is also a psychotherapist (LCSW) and has maintained a Nancy Chadwick, LCSW private practice in psychotherapy since 1976.

These two careers enhance each other, giving her clients a rich experience.


text:
subroutine driver(km, jm, im,                                 &
     Rd, Cpd, a, omega, delh, delv, Newt, dt, lat, lev,       &
     T_, U_, V_, q_, Vold_,                                   &
     Tinc_, Uinc_, Vinc_, qinc_, psi_, theta_, theta_e_, W_,  &
     Tdot_, Udot_, Vdot_, qdot_)

implicit none

! In
integer, intent(in)                       :: km,jm,im
!f2py intent(in,hide) km,jm,im
real(8), intent(in)                       :: Rd, Cpd, a, omega, delh
real(8), intent(in)                       :: delv, Newt, dt
real(8), intent(in),  dimension(jm)       :: lat
real(8), intent(in),  dimension(km)       :: lev
real(8), intent(in),  dimension(km,jm,im) :: T_, U_, q_, Vold_

real(8),  dimension(km,jm,im) :: V_
!f2py intent(in,out) V_

! Out
real(8), intent(out), dimension(km,jm,im) :: Tinc_, Uinc_, Vinc_, qinc_
real(8), intent(out), dimension(km,jm,im) :: psi_, theta_, theta_e_,  W_
real(8), intent(out), dimension(km,jm,im) :: Tdot_, Udot_, Vdot_, qdot_

! Local
real(8), dimension(jm,km) :: T, U, V, q, Vold, psi, theta
real(8), dimension(jm,km) :: Tinc, Uinc, Vinc, qinc, theta_e, p, W
real(8), dimension(jm,km) :: Tdot, Udot, Vdot, qdot

! Reshape input field (legacy code uses (j,k) instead of (k,j))
T = transpose(T_(:,:,1))
U = transpose(U_(:,:,1))
V = transpose(V_(:,:,1))
q = transpose(q_(:,:,1))
Vold = transpose(Vold_(:,:,1))

call main(km, jm,                    &
          Rd, Cpd, a, omega,         &
          delh, delv, Newt,          &
          dt, lat, lev,  &
          T, U, V, q, Vold,          &
          Tinc, Uinc, Vinc, qinc, psi, theta, theta_e, p, W, &
          Tdot, Udot, Vdot, qdot)

! Reshape for output
Tinc_(:,:,1)    = transpose(Tinc)
Uinc_(:,:,1)    = transpose(Uinc)
Vinc_(:,:,1)    = transpose(Vinc)
qinc_(:,:,1)    = transpose(qinc)
Tdot_(:,:,1)    = transpose(Tdot)
Udot_(:,:,1)    = transpose(Udot)
Vdot_(:,:,1)    = transpose(Vdot)
qdot_(:,:,1)    = transpose(qdot)
psi_(:,:,1)     = transpose(psi)
theta_(:,:,1)   = transpose(theta)
theta_e_(:,:,1) = transpose(theta_e)
W_(:,:,1)       = transpose(W)

end subroutine driver

max_stars_repo_name: CliMT/climt-legacy

max_issues_repo_name: CliMT/climt-legacy

max_forks_repo_name: CliMT/climt-legacy


text:
! RUN: %S/test_errors.sh %s %t %f18 -fopenacc

! Data-Mapping Attribute Clauses
! 2.15.14 default Clause

subroutine default_none()
  integer a(3)

  A = 1
  B = 2
  !$acc parallel default(none) private(c)
  !ERROR: The DEFAULT(NONE) clause requires that 'a' must be listed in a data-mapping clause
  A(1:2) = 3
  !ERROR: The DEFAULT(NONE) clause requires that 'b' must be listed in a data-mapping clause
  B = 4
  C = 5
  !$acc end parallel
end subroutine default_none

program mm
  call default_none()
end

max_stars_repo_name: elizabethandrews/llvm

max_issues_repo_name: elizabethandrews/llvm

max_forks_repo_name: elizabethandrews/llvm


text:
Trans Action Week is held annually in late November as a time of education and awareness around transgender and gender variant issues and experiences.  It is organized by the TransAction Committee, under the Lesbian, Gay, Bisexual and Transgender Resource Center. Events vary greatly, from speakers to self defense training, draw your gender, Trans 101 and academic discussions of community intersections (to name just a few).

The 2010 Trans Action Week was from November 15th to 19th. The schedule was as follows:

Monday, November 15th

Genderpalooza!
Join us at the MU to explore your artistic side and learn about transgender issues and activism. Draw your gender! Explore transgender identities and issues with fun activities!
MU Patio
11am1pm
cosponsored by Gender Group

HIV Testing  Free & Anonymous
Come into the LGBT Resource center for free anonymous HIV antibody testing on scheduled days, organized by the UC Davis Health Education Program. The test is “rapid”, which means that results only take 20 minutes, and is an oral swab (no blood needed!). The LGBT Resource Center is located on campus at the University House Annex across from Voorhies Hall. Walkins are welcome during testing hours. Please come in early to signup for a time slot.
LGBT Resource Center, University House Annex
68pm

Tuesday, November 16th

Trans 101
An informational discussion about basic terminology and issues relating to transgender and gender variant communities. Come with questions or just to get more information.
LGBT Resource Center, University House Annex
121pm

Categorical Difficulties: Trans Subjects and the Politics of Legibility
This academic panel of papers will trace the epistemic violence faced by gender nonconforming people, arising from the narrowlydefined gender categories available to officially identify and classify trans folks. In order to be legible within legal and social systems, gender nonconforming people are forced to narrate themselves through reductive, binary categories. This often comes at the expense of having the ability to define and imagine different ways of organizing gendered or nongendered identities, histories, and bodies. As a result, for those who fall under the umbrella term transgender, the gaining of political recognition, civil rights, and access to community benefits often comes at the expense of their own ability to define themselves. This panel will investigate these contradictions and offer strategies for navigating the politics of transgender categorization in more complex and socially responsible ways.
Hart 3201
34pm
with the Queer, Feminist, and Transgender Studies Research Cluster

Trans Safe Zone
Transgender Safe Zone is a twohour training created to raise awareness and understanding about gender identity and issues faced by Transgender people. Contact Sara Farooqi to register by phone: 5307522452 or by email: safarooqi@ucdavis.edu.
57pm

Wednesday, November 17th:

RISE UP! A TransAction Week Discussion
Rise Up is a weekly discussion series that is open to everybody and anybody who is interested in talking things out. This is a great way to come and check out the LGBT Resource Center as well as join in on casual discussions that are related to the Queer community.
LGBT Resource Center, University House Annex
121pm

Trans Resources Panel: Social & Legal Issues
Come learn about resources available to trans and gender variant people at UC Davis and in the surrounding community and get questions answered.  This panel will feature representatives from Counseling And Psychological Services (CAPS), Lamdba Law, and the Sacramento Transgender Coalition.
Voorhies 126
121:30pm

Gender Group Meeting
A weekly social/support group for anyone who identifies as falling under the trans umbrella (or a noncisgender identity) or people who are questioning their gender identity. The group is open to all trans folks of the Davis area community.  For more information email: ucd.gender@gmail.com.
56pm

Keynote: Ryka Aoki de la Cruz
Ryka Aoki is a writer, performer, and educator who has been honored by the California State Senate for creating Trans/Giving, LA’s only art/performance series dedicated to trans, genderqueer, and intersex artists. She has also closely worked with the American Association of HiroshimaNagasaki ABomb Survivors, and two of her compositions were adopted by the group as its “Songs of Peace.” Ryka appears in the recent trans documentaries “Diagnosing Difference” and “Riot Acts” as well as the Anthology Gender Outlaws: The Next Generation (Seal Press).

Ryka was the inaugural performer for San Francisco’s first ever Transgender Stage at San Francisco Pride 2005, and has performed in venues including the San Francisco Pride Main Stage, the Columbus National Gay and Lesbian Theatre Festival, the National Queer Arts Festival, Ladyfest South, Atlanta Pride, UCLA’s OutCRY, Santa Cruz Pride, and Emory University’s Pride Week. Ryka was keynote speaker at UC Santa Barbara’s 2005 Pride Week, GenderFusions 2008 at Columbia College, and UW Madison’s Trans Awareness Week 2009.

Ryka has as an MFA in Creative Writing from Cornell University and is the recipient of a University Award from the Academy of American Poets. Her chapbook, Sometimes Too Hot the Eye of Heaven Shines (Incognito Press) won the 2010 Eli Coppola Chapbook Contest. Ryka’s poetry is forthcoming in the 2011 edition of Many Mountains Moving, and Hummingbird Review. She is a professor of English at Santa Monica College.

Wellman 106
7pm

Thursday, November 18th

Trans Resources Panel: Medical Issues
Come learn about resources available to trans and gender variant people at UC Davis and in the surrounding community, connect with important providers, and get questions answered. This panel will feature representatives from Student Health Services and Counseling And Psychological Services (CAPS).
Voorhies 126
121:30pm

Friday, November 19th

TransForming Body Image
Traditionally, body image has been discussed in a way that is gender dichotomous and not inclusive of varying expressions of identity.  This workshop will explore messages about appearance and gender and how they impact body image and self esteem.  Presenters from Counseling And Psychological Services (CAPS) will help participants feel empowered to explore body image in a healthy way that allows for integration of intersecting identities.  This workshop assumes a preexisting level of familiarity with basic issues around gender identity.
North Hall 325
11am12:30pm

Crafternoons!
Create your gender in 3D! Come craft and hang out at the LGBTRC! Everyones welcome  supplies and abundant crafting knowledge provided!
LGBT Resource Center, University House Annex
3:305pm

Transgender Day of Remembrance
Join us to memorialize those who have been killed due to antitransgender hatred and prejudice, to heal in community and solidarity, and to affirm and celebrate the lives of humans of all gender identities.
Central Park Green
5pm
with the Unitarian Universalist Church of Davis

Other events in the past, cut for various reasons such as budget cuts, staffing, or time constraints, have included:

Understanding Violence in Our Communities
SelfDefense Workshop
Allies Against Violence
Lights, Camera, TransAction!

Past keynotes have included Julie Wyman, Eli Clare and Sam Feder.


text:
The City of Davis used to offer the community an informal and confidential forum for dispute resolution via the Community Mediation Services. They were located at 23 Russell Blvd and could be reached at (530) 7575623.

Useful for:
  Neighborhood difficulties
  Tenant/landlord disputes
  Customer/merchant issues
  Roommate and coworker conflicts
  Conflict resolution training
  Community workshops
  Meaningful volunteer opportunities
  Facilitation of neighborhood and community meetings


!!
!! Copyright (C) 2014 Andreas van Hameren.
!!
!! This file is part of OneLOop-3.4.
!!
!! OneLOop-3.4 is free software: you can redistribute it and/or modify
!! it under the terms of the GNU General Public License as published by
!! the Free Software Foundation, either version 3 of the License, or
!! (at your option) any later version.
!!
!! OneLOop-3.4 is distributed in the hope that it will be useful,
!! but WITHOUT ANY WARRANTY; without even the implied warranty of
!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!! GNU General Public License for more details.
!!
!! You should have received a copy of the GNU General Public License
!! along with OneLOop-3.4.  If not, see <http://www.gnu.org/licenses/>.
!!

module avh_olo_forIREGI_qmplx
  use avh_olo_forIREGI_units
  use avh_olo_forIREGI_prec
  use avh_olo_forIREGI_auxfun
  use avh_olo_forIREGI_olog
  use avh_olo_forIREGI_dilog

  implicit none
  private
  public :: qmplx_type,qonv,directly,sheet,logc,logc2,li2c,li2c2
  public :: operator (*) ,operator (/)

  type :: qmplx_type
  include 'avh_olo_complex.h90'
          :: c
  integer :: p
  end type

  interface qonv
    module procedure qonv_cr,qonv_ci,qonv_c,qonv_i
  end interface

  interface operator (*)
    module procedure prduct_qq,prduct_qr
  end interface
  interface operator (/)
    module procedure ratio_qq,ratio_qr
  end interface

contains

  function qonv_cr(xx,sgn) result(rslt)
!*******************************************************************
! zz=rslt%c ,iz=rslt%p
! Determine  zz,iz  such that  xx = zz*exp(iz*imag*pi)  and  Re(zz)
! is positive. If  Im(x)=0  and  Re(x)<0  then  iz  becomes the
! sign of  sgn .
!*******************************************************************
  include 'avh_olo_complex.h90'
    ,intent(in) :: xx
  include 'avh_olo_real.h90'
    ,intent(in) :: sgn
  type(qmplx_type) :: rslt
  include 'avh_olo_real.h90'
    :: xre,xim
  xre = areal(xx)
  if (xre.ge.RZRO) then
    rslt%c = xx
    rslt%p = 0
  else
    xim = aimag(xx)
    if (xim.eq.RZRO) then
      rslt%c = -xre
      rslt%p = sgnRe(sgn)
    else
      rslt%c = -xx
      rslt%p = sgnRe(xim) ! xim = -Im(rslt%c)
    endif
  endif
  end function

  function qonv_ci(xx,sgn) result(rslt)
!*******************************************************************
! zz=rslt%c ,iz=rslt%p
! Determine  zz,iz  such that  xx = zz*exp(iz*imag*pi)  and  Re(zz)
! is positive. If  Im(x)=0  and  Re(x)<0  then  iz  becomes the
! sign of  sgn .
!*******************************************************************
  include 'avh_olo_complex.h90'
    ,intent(in) :: xx
  integer         ,intent(in) :: sgn
  type(qmplx_type) :: rslt
  include 'avh_olo_real.h90'
    :: xre,xim
  xre = areal(xx)
  if (xre.ge.RZRO) then
    rslt%c = xx
    rslt%p = 0
  else
    xim = aimag(xx)
    if (xim.eq.RZRO) then
      rslt%c = -xre
      rslt%p = sign(1,sgn)
    else
      rslt%c = -xx
      rslt%p = sgnRe(xim) ! xim = -Im(rslt%c)
    endif
  endif
  end function

  function qonv_c(xx) result(rslt)
!*******************************************************************
! zz=rslt%c ,iz=rslt%p
! Determine  zz,iz  such that  xx = zz*exp(iz*imag*pi)  and  Re(zz)
! is positive. If  Im(x)=0  and  Re(x)<0  then  iz=1
!*******************************************************************
  include 'avh_olo_complex.h90'
    ,intent(in) :: xx
  type(qmplx_type) :: rslt
  include 'avh_olo_real.h90'
    :: xre,xim
  xre = areal(xx)
  if (xre.ge.RZRO) then
    rslt%c = xx
    rslt%p = 0
  else
    xim = aimag(xx)
    if (xim.eq.RZRO) then
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop qonv_c: ' &
        ,'negative input with undefined sign for the imaginary part, ' &
        ,'putting +ieps'
      rslt%c = -xre
      rslt%p = 1
    else
      rslt%c = -xx
      rslt%p = sgnRe(xim) ! xim = -Im(rslt%c)
    endif
  endif
  end function

  function qonv_i(xx) result(rslt)
!*******************************************************************
! zz=rslt%c ,iz=rslt%p
! Determine  zz,iz  such that  xx = zz*exp(iz*imag*pi)  and  Re(zz)
! is positive. If  Im(x)=0  and  Re(x)<0  then  iz=1
!*******************************************************************
  integer ,intent(in) :: xx
  type(qmplx_type) :: rslt
  if (xx.ge.0) then
    rslt%c = xx
    rslt%p = 0
  else
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop qonv_i: ' &
      ,'negative input with undefined sign for the imaginary part, ' &
      ,'putting +ieps'
    rslt%c = -xx
    rslt%p = 1
  endif
  end function

  function directly(xx,ix) result(rslt)
!*******************************************************************
!*******************************************************************
  include 'avh_olo_complex.h90'
    ,intent(in) :: xx
  integer         ,intent(in) :: ix
  type(qmplx_type) :: rslt
  rslt%c = xx
  rslt%p = ix
  end function

  function sheet(xx) result(ii)
!*******************************************************************
! Returns the number of the Riemann-sheet (times 2) for the complex
! number  xx*exp(ix*imag*pi) . The real part of xx is assumed to be
! positive or zero. Examples:
! xx=1+imag, ix=-1 -> ii= 0
! xx=1+imag, ix= 1 -> ii= 2
! xx=1-imag, ix=-1 -> ii=-2
! xx=1-imag, ix= 1 -> ii= 0
! xx=1     , ix= 1 -> ii= 0  convention that log(-1)=pi on
! xx=1     , ix=-1 -> ii=-2  the principal Riemann-sheet
!*******************************************************************
  type(qmplx_type) ,intent(in) :: xx
  integer :: ii,jj
  include 'avh_olo_real.h90'
    :: xim
  jj = mod(xx%p,2)
  ii = xx%p-jj
  xim = aimag(xx%c)
  if (xim.le.RZRO) then ! also xim=0 <==> log(-1)=pi, not -pi
    if (jj.eq.-1) ii = ii-2
  else
    if (jj.eq. 1) ii = ii+2
  endif
  end function

  function prduct_qq(yy,xx) result(zz)
!*******************************************************************
! Return the product  zz  of  yy  and  xx
! keeping track of (the multiple of pi of) the phase %p such that
! the real part of  zz%c  remains positive
!*******************************************************************
  type(qmplx_type) ,intent(in) :: yy,xx
  type(qmplx_type) :: zz
  zz%c = yy%c*xx%c
  zz%p = yy%p+xx%p
  if (areal(zz%c).lt.RZRO) then
    zz%p = zz%p + sgnIm(xx%c)
    zz%c = -zz%c
  endif
  end function

  function prduct_qr(yy,xx) result(zz)
!*******************************************************************
! Return the product  zz  of  yy  and  xx
! keeping track of (the multiple of pi of) the phase %p such that
! the real part of  zz%c  remains positive
!*******************************************************************
  type(qmplx_type) ,intent(in) :: yy
  include 'avh_olo_real.h90'
    ,intent(in) :: xx
  type(qmplx_type) :: zz
  zz%c = yy%c*abs(xx)
  zz%p = yy%p
  end function

  function ratio_qq(yy,xx) result(zz)
!*******************************************************************
! Return the ratio  zz  of  yy  and  xx
! keeping track of (the multiple of pi of) the phase %p such that
! the real part of  zz%c  remains positive
!*******************************************************************
  type(qmplx_type) ,intent(in) :: yy,xx
  type(qmplx_type) :: zz
  zz%c = yy%c/xx%c
  zz%p = yy%p-xx%p
  if (areal(zz%c).lt.RZRO) then
    zz%p = zz%p - sgnIm(xx%c)
    zz%c = -zz%c
  endif
  end function

  function ratio_qr(yy,xx) result(zz)
!*******************************************************************
!*******************************************************************
  type(qmplx_type) ,intent(in) :: yy
  include 'avh_olo_real.h90'
    ,intent(in) :: xx
  type(qmplx_type) :: zz
  zz%c = yy%c/abs(xx)
  zz%p = yy%p
  end function

  function logc(xx) result(rslt)
!*******************************************************************
! log(xx)
!*******************************************************************
  type(qmplx_type) ,intent(in) :: xx
  include 'avh_olo_complex.h90'
    :: rslt
!  rslt = olog(acmplx(xx%c),xx%p)
  rslt = olog(xx%c,xx%p)
  end function

  function logc2(xx) result(rslt)
!*******************************************************************
! log(xx)/(1-xx)
!*******************************************************************
  type(qmplx_type) ,intent(in) :: xx
  include 'avh_olo_complex.h90'
    :: rslt
!  rslt = -olog2(acmplx(xx%c),xx%p)
  rslt = -olog2(xx%c,xx%p)
  end function

  function li2c(xx) result(rslt)
!*******************************************************************
!    /1    ln(1-(1-xx)*t)
!  - |  dt --------------
!    /0        t
!*******************************************************************
  type(qmplx_type) ,intent(in) :: xx
  include 'avh_olo_complex.h90'
    :: rslt
!  rslt = dilog(acmplx(xx%c),xx%p)
  rslt = dilog(xx%c,xx%p)
  end function

  function li2c2(xx,yy) result(rslt)
!*******************************************************************
! ( li2(xx) - li2(yy) )/(xx-yy)
!*******************************************************************
  type(qmplx_type) ,intent(in) :: xx,yy
  include 'avh_olo_complex.h90'
    :: rslt
!  rslt = dilog( acmplx(xx%c),xx%p ,acmplx(yy%c),yy%p )
!  write(*,*) 'li2c2 x:',xx%c,xx%p !DEBUG
!  write(*,*) 'li2c2 y:',yy%c,yy%p !DEBUG
  rslt = dilog( xx%c,xx%p ,yy%c,yy%p )
!  write(*,*) 'li2c2 out:',rslt !DEBUG
  end function

end module


text:
      subroutine read_segments(iunit,segmentsfile,
     &             nsegmax,nsegment,xlsegmin,xlsegmax)
!
! read wavelengths segments to be calculated
! BPz 03/07-2020
!
      implicit none
      integer nsegment,nsegmax,i,iunit
      doubleprecision xlsegmin(*),xlsegmax(*)
      character segmentsfile*256,header*256
      logical head
!
      open(iunit,file=segmentsfile,status='old')
      head = .true.
      do while (head)
        read(iunit,10) header
        if (header(1:1).eq.';') then
          head=.true.
        else
          head=.false.
        endif
      enddo
      backspace(iunit)
      do i=1,nsegmax+1
        read(iunit,*,end=99) xlsegmin(i),xlsegmax(i)
        nsegment=i
      enddo
      print*,'number of segments too high!'
      print*,'increase nsegmax!'
      stop ' stop in read_segments'
99    continue
      print*,'Read ',nsegment,' wavelengths segments'
      return
10    format(a)
      end

max_stars_repo_name: sdss/apogee

max_issues_repo_name: sdss/apogee

max_forks_repo_name: sdss/apogee


text:
      module syncio
      use :: iso_c_binding
      interface
        subroutine syncio_setup_read(nfiles, handle)
     &   bind(C, NAME='syncio_setup_read')
        use :: iso_c_binding
          integer(c_int), value :: nfiles
          type(c_ptr) :: handle
        end subroutine
        subroutine syncio_setup_write(nfiles, nfields, nppf, handle)
     &   bind(C, NAME='syncio_setup_write')
        use :: iso_c_binding
          integer(c_int), value :: nfiles
          integer(c_int), value :: nfields
          integer(c_int), value :: nppf
          type(c_ptr) :: handle
        end subroutine
      end interface
      end module


program non_axisymmetric_potential
    use physics
    use bulirsch_stoer
    implicit none
    ! to do:
    !   figure out how to make it so I don't have to explicitly use 'accuracy.f08'
    !       within bulirsch_stoer.f08
    !       -- that would help make this a bit easier to use modularly

    ! the main things you need to set are:
    !    In physics_non_axisymmetric.f08:
    !       - precision - sets float precision (e.g. 8 = double)
    !       - energy_tol - fractional tolerance for energy conservation *each step*
    !       - eccentricity - eccentricity of the potential well
    !       - energy_initial - defines family of orbits
    !

    !   In this file:
    !       - n_bodies
    !           - will automatically start n_bodies of integration,
    !             spaced throughout the initially allowed x_values ( 0 < x_0 < x_max )
    !       - t_max
    !           - how long should the integration continue?
    !       - t_print
    !           - how often should you print?

    integer, parameter                              :: n_bodies = 100
    ! 3-position, 3-velocity
    real(kind=precision), dimension(n_bodies, 3)    :: x, v
    real(kind=precision), dimension(n_bodies)       :: mass

    real(kind=precision), parameter     :: H_big = 1./real(10**(4), kind=precision) ! large step size
    real(kind=precision)                :: t
    real(kind=precision), parameter     :: t_max   = 100.
    real(kind=precision), parameter     :: t_print = .001  ! print every t_print,

    ! defined in the physics module -- changes for each potential
    type(accuracy_state)                :: state_initial, state_final

    integer                             :: i,j,k        ! loop variables

    integer                             :: save_file_unit
    character(len=6)                    :: ith_body_str ! tmp variable used in filenames
    character(len=15)                   :: filename     ! tmp variable used in filenames
    character(len=15)                   :: data_format  ! for saving

    ! INITIALIZE

    ! initialize x_0 to a range of 0 < x_0 < x_max
    do concurrent (i=1:n_bodies)
        x(i,1) = x_max * i / (n_bodies + 1)
        x(i,2) = 0
        x(i,3) = 0
    end do

    mass = 1.

    call calc_initial_velocity(n_bodies, x, v)

    call state_initial%initialize(n_bodies, x, v, mass)

    print *, 'energy (initial): '
    print *,  state_initial%energy

    print *, '---'
    print *, 'x_max:'
    print *, x_max
    print *, 'x_0: '
    print *, x(:,1)

    print *, ''
    print *, 'v_y: '
    print *, v(:,2)

    ! ! ! BEGIN INTEGRATIONS
    data_format = "(7e13.5)"
    do i = 1,n_bodies
        print *, 'starting body: '
        print *, i
        write (ith_body_str, "(I4.4)") i
        filename = 'body_'//trim(ith_body_str)//'.dat'

        open(newunit=save_file_unit, file=filename, status='unknown')
        write(save_file_unit, *) &
            "t",achar(9),achar(9),achar(9),achar(9),&
            "x",achar(9),achar(9),achar(9),achar(9),&
            "y",achar(9),achar(9),achar(9),achar(9),&
            "z",achar(9),achar(9),achar(9),achar(9),&
            "v_x",achar(9),achar(9),achar(9),achar(9),&
            "v_y",achar(9),achar(9),achar(9),achar(9),&
            "v_z"

        t = 0.
        do j=1,int(t_max/ H_big)
            t = t + H_big
            ! bodies are uncoupled; faster if integrated separately
            call bulirsch_stoer_step(1, x(i,:), v(i,:), mass(i), H_big)

!             print *, 't = '
!             print *, j * H_big
            if (mod(j, int(t_print / H_big)).eq.0) then
                write(save_file_unit,data_format) &
                t, &
                x(i,1), &
                x(i,2), &
                x(i,3), &
                v(i,1), &
                v(i,2), &
                v(i,3)
            endif
        end do
        close(save_file_unit)
    end do

    ! ! ! CHECK FINAL RESULTS
    call state_final%initialize(n_bodies, x, v, mass)

    print *, ""
    print *, 'energy (final): '
    print *,  state_final%energy

    print *, "overall conservation:"
    print *, "energy err:"
    print *, abs( (state_final%energy - state_initial%energy) / state_initial%energy )

end program


text:
module dep_mod
end module dep_mod

max_stars_repo_name: clementval/claw-compiler

max_issues_repo_name: skosukhin/claw-compiler

max_forks_repo_name: skosukhin/claw-compiler


submodule(forlab_io) forlab_io_progress_bar

    implicit none

contains

    module subroutine progress_bar_int8(iter, itermax, step, symbol)

        integer(int8), intent(in) :: iter, itermax
        integer(int8), intent(in), optional :: step
        character(*), intent(in), optional :: symbol

        integer(int8) :: step_, i, percentage
        character(:), allocatable :: symbol_, bar

        step_ = optval(step, 50_int8)
        symbol_ = optval(symbol, "=")

        bar = "  ["
        do i = 1_int8, step_
            bar = bar//" "
        end do
        bar = bar//"]"

        percentage = real(iter)/real(itermax)*100.0

        do i = 1_int8, floor(percentage/(100.0/step_), int8)
            bar(3_int8 + i:3_int8 + i) = symbol_
        end do

        i = ceiling((step_ + 2_int8)/2.0, int8)
        write (bar(i + 1_int8:i + 3_int8), "(i3)") percentage
        bar(i + 4_int8:i + 4_int8) = "%"

        if (percentage < 100_int8 .and. percentage > 50_int8 - 100_int8/step_) &
            bar(i + 1_int8:i + 1_int8) = symbol_

        write (*, "(a1, A)", advance="no") achar(13), bar

    end subroutine progress_bar_int8
    module subroutine progress_bar_int16(iter, itermax, step, symbol)

        integer(int16), intent(in) :: iter, itermax
        integer(int16), intent(in), optional :: step
        character(*), intent(in), optional :: symbol

        integer(int16) :: step_, i, percentage
        character(:), allocatable :: symbol_, bar

        step_ = optval(step, 50_int16)
        symbol_ = optval(symbol, "=")

        bar = "  ["
        do i = 1_int16, step_
            bar = bar//" "
        end do
        bar = bar//"]"

        percentage = real(iter)/real(itermax)*100.0

        do i = 1_int16, floor(percentage/(100.0/step_), int16)
            bar(3_int16 + i:3_int16 + i) = symbol_
        end do

        i = ceiling((step_ + 2_int16)/2.0, int16)
        write (bar(i + 1_int16:i + 3_int16), "(i3)") percentage
        bar(i + 4_int16:i + 4_int16) = "%"

        if (percentage < 100_int16 .and. percentage > 50_int16 - 100_int16/step_) &
            bar(i + 1_int16:i + 1_int16) = symbol_

        write (*, "(a1, A)", advance="no") achar(13), bar

    end subroutine progress_bar_int16
    module subroutine progress_bar_int32(iter, itermax, step, symbol)

        integer(int32), intent(in) :: iter, itermax
        integer(int32), intent(in), optional :: step
        character(*), intent(in), optional :: symbol

        integer(int32) :: step_, i, percentage
        character(:), allocatable :: symbol_, bar

        step_ = optval(step, 50_int32)
        symbol_ = optval(symbol, "=")

        bar = "  ["
        do i = 1_int32, step_
            bar = bar//" "
        end do
        bar = bar//"]"

        percentage = real(iter)/real(itermax)*100.0

        do i = 1_int32, floor(percentage/(100.0/step_), int32)
            bar(3_int32 + i:3_int32 + i) = symbol_
        end do

        i = ceiling((step_ + 2_int32)/2.0, int32)
        write (bar(i + 1_int32:i + 3_int32), "(i3)") percentage
        bar(i + 4_int32:i + 4_int32) = "%"

        if (percentage < 100_int32 .and. percentage > 50_int32 - 100_int32/step_) &
            bar(i + 1_int32:i + 1_int32) = symbol_

        write (*, "(a1, A)", advance="no") achar(13), bar

    end subroutine progress_bar_int32
    module subroutine progress_bar_int64(iter, itermax, step, symbol)

        integer(int64), intent(in) :: iter, itermax
        integer(int64), intent(in), optional :: step
        character(*), intent(in), optional :: symbol

        integer(int64) :: step_, i, percentage
        character(:), allocatable :: symbol_, bar

        step_ = optval(step, 50_int64)
        symbol_ = optval(symbol, "=")

        bar = "  ["
        do i = 1_int64, step_
            bar = bar//" "
        end do
        bar = bar//"]"

        percentage = real(iter)/real(itermax)*100.0

        do i = 1_int64, floor(percentage/(100.0/step_), int64)
            bar(3_int64 + i:3_int64 + i) = symbol_
        end do

        i = ceiling((step_ + 2_int64)/2.0, int64)
        write (bar(i + 1_int64:i + 3_int64), "(i3)") percentage
        bar(i + 4_int64:i + 4_int64) = "%"

        if (percentage < 100_int64 .and. percentage > 50_int64 - 100_int64/step_) &
            bar(i + 1_int64:i + 1_int64) = symbol_

        write (*, "(a1, A)", advance="no") achar(13), bar

    end subroutine progress_bar_int64

end submodule forlab_io_progress_bar


program P4
  implicit none
  real*4 :: pi,one
  real*8 :: pi8,one8

  one=1.
  one8=1.
  pi=atan(one)*4
  pi8=atan(one8)*4

  print "('pi in single ',f20.18,' and pi in double ',f20.18)", pi,pi8

end program P4


text:
*> \brief \b SERRRFP
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SERRRFP( NUNIT )
*
*       .. Scalar Arguments ..
*       INTEGER            NUNIT
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SERRRFP tests the error exits for the REAL driver routines
*> for solving linear systems of equations.
*>
*> SDRVRFP tests the REAL LAPACK RFP routines:
*>     STFSM, STFTRI, SSFRK, STFTTP, STFTTR, SPFTRF, SPFTRS, STPTTF,
*>     STPTTR, STRTTF, and STRTTP
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] NUNIT
*> \verbatim
*>          NUNIT is INTEGER
*>          The unit number for output.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup single_lin
*
*  =====================================================================
      SUBROUTINE SERRRFP( NUNIT )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER            NUNIT
*     ..
*
*  =====================================================================
*
*     ..
*     .. Local Scalars ..
      INTEGER            INFO
      REAL               ALPHA, BETA
*     ..
*     .. Local Arrays ..
      REAL               A( 1, 1), B( 1, 1)
*     ..
*     .. External Subroutines ..
      EXTERNAL           CHKXER, STFSM, STFTRI, SSFRK, STFTTP, STFTTR,
     +                   SPFTRI, SPFTRF, SPFTRS, STPTTF, STPTTR, STRTTF,
     +                   STRTTP
*     ..
*     .. Scalars in Common ..
      LOGICAL            LERR, OK
      CHARACTER*32       SRNAMT
      INTEGER            INFOT, NOUT
*     ..
*     .. Common blocks ..
      COMMON             / INFOC / INFOT, NOUT, OK, LERR
      COMMON             / SRNAMC / SRNAMT
*     ..
*     .. Executable Statements ..
*
      NOUT = NUNIT
      OK = .TRUE.
      A( 1, 1 ) = 1.0E+0
      B( 1, 1 ) = 1.0E+0
      ALPHA     = 1.0E+0
      BETA      = 1.0E+0
*
      SRNAMT = 'SPFTRF'
      INFOT = 1
      CALL SPFTRF( '/', 'U', 0, A, INFO )
      CALL CHKXER( 'SPFTRF', INFOT, NOUT, LERR, OK )
      INFOT = 2
      CALL SPFTRF( 'N', '/', 0, A, INFO )
      CALL CHKXER( 'SPFTRF', INFOT, NOUT, LERR, OK )
      INFOT = 3
      CALL SPFTRF( 'N', 'U', -1, A, INFO )
      CALL CHKXER( 'SPFTRF', INFOT, NOUT, LERR, OK )
*
      SRNAMT = 'SPFTRS'
      INFOT = 1
      CALL SPFTRS( '/', 'U', 0, 0, A, B, 1, INFO )
      CALL CHKXER( 'SPFTRS', INFOT, NOUT, LERR, OK )
      INFOT = 2
      CALL SPFTRS( 'N', '/', 0, 0, A, B, 1, INFO )
      CALL CHKXER( 'SPFTRS', INFOT, NOUT, LERR, OK )
      INFOT = 3
      CALL SPFTRS( 'N', 'U', -1, 0, A, B, 1, INFO )
      CALL CHKXER( 'SPFTRS', INFOT, NOUT, LERR, OK )
      INFOT = 4
      CALL SPFTRS( 'N', 'U', 0, -1, A, B, 1, INFO )
      CALL CHKXER( 'SPFTRS', INFOT, NOUT, LERR, OK )
      INFOT = 7
      CALL SPFTRS( 'N', 'U', 0, 0, A, B, 0, INFO )
      CALL CHKXER( 'SPFTRS', INFOT, NOUT, LERR, OK )
*
      SRNAMT = 'SPFTRI'
      INFOT = 1
      CALL SPFTRI( '/', 'U', 0, A, INFO )
      CALL CHKXER( 'SPFTRI', INFOT, NOUT, LERR, OK )
      INFOT = 2
      CALL SPFTRI( 'N', '/', 0, A, INFO )
      CALL CHKXER( 'SPFTRI', INFOT, NOUT, LERR, OK )
      INFOT = 3
      CALL SPFTRI( 'N', 'U', -1, A, INFO )
      CALL CHKXER( 'SPFTRI', INFOT, NOUT, LERR, OK )
*
      SRNAMT = 'STFSM '
      INFOT = 1
      CALL STFSM( '/', 'L', 'U', 'T', 'U', 0, 0, ALPHA, A, B, 1 )
      CALL CHKXER( 'STFSM ', INFOT, NOUT, LERR, OK )
      INFOT = 2
      CALL STFSM( 'N', '/', 'U', 'T', 'U', 0, 0, ALPHA, A, B, 1 )
      CALL CHKXER( 'STFSM ', INFOT, NOUT, LERR, OK )
      INFOT = 3
      CALL STFSM( 'N', 'L', '/', 'T', 'U', 0, 0, ALPHA, A, B, 1 )
      CALL CHKXER( 'STFSM ', INFOT, NOUT, LERR, OK )
      INFOT = 4
      CALL STFSM( 'N', 'L', 'U', '/', 'U', 0, 0, ALPHA, A, B, 1 )
      CALL CHKXER( 'STFSM ', INFOT, NOUT, LERR, OK )
      INFOT = 5
      CALL STFSM( 'N', 'L', 'U', 'T', '/', 0, 0, ALPHA, A, B, 1 )
      CALL CHKXER( 'STFSM ', INFOT, NOUT, LERR, OK )
      INFOT = 6
      CALL STFSM( 'N', 'L', 'U', 'T', 'U', -1, 0, ALPHA, A, B, 1 )
      CALL CHKXER( 'STFSM ', INFOT, NOUT, LERR, OK )
      INFOT = 7
      CALL STFSM( 'N', 'L', 'U', 'T', 'U', 0, -1, ALPHA, A, B, 1 )
      CALL CHKXER( 'STFSM ', INFOT, NOUT, LERR, OK )
      INFOT = 11
      CALL STFSM( 'N', 'L', 'U', 'T', 'U', 0, 0, ALPHA, A, B, 0 )
      CALL CHKXER( 'STFSM ', INFOT, NOUT, LERR, OK )
*
      SRNAMT = 'STFTRI'
      INFOT = 1
      CALL STFTRI( '/', 'L', 'N', 0, A, INFO )
      CALL CHKXER( 'STFTRI', INFOT, NOUT, LERR, OK )
      INFOT = 2
      CALL STFTRI( 'N', '/', 'N', 0, A, INFO )
      CALL CHKXER( 'STFTRI', INFOT, NOUT, LERR, OK )
      INFOT = 3
      CALL STFTRI( 'N', 'L', '/', 0, A, INFO )
      CALL CHKXER( 'STFTRI', INFOT, NOUT, LERR, OK )
      INFOT = 4
      CALL STFTRI( 'N', 'L', 'N', -1, A, INFO )
      CALL CHKXER( 'STFTRI', INFOT, NOUT, LERR, OK )
*
      SRNAMT = 'STFTTR'
      INFOT = 1
      CALL STFTTR( '/', 'U', 0, A, B, 1, INFO )
      CALL CHKXER( 'STFTTR', INFOT, NOUT, LERR, OK )
      INFOT = 2
      CALL STFTTR( 'N', '/', 0, A, B, 1, INFO )
      CALL CHKXER( 'STFTTR', INFOT, NOUT, LERR, OK )
      INFOT = 3
      CALL STFTTR( 'N', 'U', -1, A, B, 1, INFO )
      CALL CHKXER( 'STFTTR', INFOT, NOUT, LERR, OK )
      INFOT = 6
      CALL STFTTR( 'N', 'U', 0, A, B, 0, INFO )
      CALL CHKXER( 'STFTTR', INFOT, NOUT, LERR, OK )
*
      SRNAMT = 'STRTTF'
      INFOT = 1
      CALL STRTTF( '/', 'U', 0, A, 1, B, INFO )
      CALL CHKXER( 'STRTTF', INFOT, NOUT, LERR, OK )
      INFOT = 2
      CALL STRTTF( 'N', '/', 0, A, 1, B, INFO )
      CALL CHKXER( 'STRTTF', INFOT, NOUT, LERR, OK )
      INFOT = 3
      CALL STRTTF( 'N', 'U', -1, A, 1, B, INFO )
      CALL CHKXER( 'STRTTF', INFOT, NOUT, LERR, OK )
      INFOT = 5
      CALL STRTTF( 'N', 'U', 0, A, 0, B, INFO )
      CALL CHKXER( 'STRTTF', INFOT, NOUT, LERR, OK )
*
      SRNAMT = 'STFTTP'
      INFOT = 1
      CALL STFTTP( '/', 'U', 0, A, B, INFO )
      CALL CHKXER( 'STFTTP', INFOT, NOUT, LERR, OK )
      INFOT = 2
      CALL STFTTP( 'N', '/', 0, A, B, INFO )
      CALL CHKXER( 'STFTTP', INFOT, NOUT, LERR, OK )
      INFOT = 3
      CALL STFTTP( 'N', 'U', -1, A, B, INFO )
      CALL CHKXER( 'STFTTP', INFOT, NOUT, LERR, OK )
*
      SRNAMT = 'STPTTF'
      INFOT = 1
      CALL STPTTF( '/', 'U', 0, A, B, INFO )
      CALL CHKXER( 'STPTTF', INFOT, NOUT, LERR, OK )
      INFOT = 2
      CALL STPTTF( 'N', '/', 0, A, B, INFO )
      CALL CHKXER( 'STPTTF', INFOT, NOUT, LERR, OK )
      INFOT = 3
      CALL STPTTF( 'N', 'U', -1, A, B, INFO )
      CALL CHKXER( 'STPTTF', INFOT, NOUT, LERR, OK )
*
      SRNAMT = 'STRTTP'
      INFOT = 1
      CALL STRTTP( '/', 0, A, 1,  B, INFO )
      CALL CHKXER( 'STRTTP', INFOT, NOUT, LERR, OK )
      INFOT = 2
      CALL STRTTP( 'U', -1, A, 1,  B, INFO )
      CALL CHKXER( 'STRTTP', INFOT, NOUT, LERR, OK )
      INFOT = 4
      CALL STRTTP( 'U', 0, A, 0,  B, INFO )
      CALL CHKXER( 'STRTTP', INFOT, NOUT, LERR, OK )
*
      SRNAMT = 'STPTTR'
      INFOT = 1
      CALL STPTTR( '/', 0, A, B, 1,  INFO )
      CALL CHKXER( 'STPTTR', INFOT, NOUT, LERR, OK )
      INFOT = 2
      CALL STPTTR( 'U', -1, A, B, 1,  INFO )
      CALL CHKXER( 'STPTTR', INFOT, NOUT, LERR, OK )
      INFOT = 5
      CALL STPTTR( 'U', 0, A, B, 0, INFO )
      CALL CHKXER( 'STPTTR', INFOT, NOUT, LERR, OK )
*
      SRNAMT = 'SSFRK '
      INFOT = 1
      CALL SSFRK( '/', 'U', 'N', 0, 0, ALPHA, A, 1, BETA, B )
      CALL CHKXER( 'SSFRK ', INFOT, NOUT, LERR, OK )
      INFOT = 2
      CALL SSFRK( 'N', '/', 'N', 0, 0, ALPHA, A, 1, BETA, B )
      CALL CHKXER( 'SSFRK ', INFOT, NOUT, LERR, OK )
      INFOT = 3
      CALL SSFRK( 'N', 'U', '/', 0, 0, ALPHA, A, 1, BETA, B )
      CALL CHKXER( 'SSFRK ', INFOT, NOUT, LERR, OK )
      INFOT = 4
      CALL SSFRK( 'N', 'U', 'N', -1, 0, ALPHA, A, 1, BETA, B )
      CALL CHKXER( 'SSFRK ', INFOT, NOUT, LERR, OK )
      INFOT = 5
      CALL SSFRK( 'N', 'U', 'N', 0, -1, ALPHA, A, 1, BETA, B )
      CALL CHKXER( 'SSFRK ', INFOT, NOUT, LERR, OK )
      INFOT = 8
      CALL SSFRK( 'N', 'U', 'N', 0, 0, ALPHA, A, 0, BETA, B )
      CALL CHKXER( 'SSFRK ', INFOT, NOUT, LERR, OK )
*
*     Print a summary line.
*
      IF( OK ) THEN
         WRITE( NOUT, FMT = 9999 )
      ELSE
         WRITE( NOUT, FMT = 9998 )
      END IF
*
 9999 FORMAT( 1X, 'REAL RFP routines passed the tests of ',
     $        'the error exits' )
 9998 FORMAT( ' *** RFP routines failed the tests of the error ',
     $        'exits ***' )
      RETURN
*
*     End of SERRRFP
*
      END

max_stars_repo_name: sydha/Lapack

max_issues_repo_name: sydha/Lapack

max_forks_repo_name: sydha/Lapack