text:
There are several metal and wood shops in Davis, on campus and off:

Open to the Public

  The Craft Center has both types of shops and welding, prices vary by resources used.

Students Only

  The Art Building has both a wood shop and a metal shop.  I believe that it is technically reserved for UCD art students that are taking an art class, most commonly a sculpture class.  They have many hand tools and also a big sander, grinder, bandsaw (big one and small one), table saw (with autostop function if you slip your hand onto the blade on accident), radial arm saw, and a few others that are broken.  The metal shop (which is outdoors but covered) has a lot of hulking machines and I dont know what they do.  You can weld here.  Gilbert is the shoptech as of 2008, and there are several volunteer monitors that come in at assorted hours throughout the week to make the shop available to more people.

  Roessler Hall has both a metal and wood shop.  They offer a machine shop engineering class here.

  Walker Hall should have a shop, if the Design Department wants to hold the design title, but I dont believe it does.  The Furniture Design room (TB102, next to Walker) probably has some kind of tools, though Im not sure what they have and it seems very closed off to non Design 135B (Furniture Design)  takers.

  Davis Senior High School has a metal shop.
  Holmes Junior High School has a metal shop and a wood shop.
  Emerson Junior High School has a wood shop.

GC welding services is a mobile welder who can come to you

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
! { dg-do run }
! PR25828 Stream IO test 2
! Contributed by Jerry DeLisle <jvdelisle@verizon.net>.
PROGRAM readUstream
  IMPLICIT NONE
  CHARACTER*3 :: string
  INTEGER :: n
  string = "123"
  n = 13579
  OPEN(UNIT=11, FILE="streamio2", ACCESS="STREAM")
  WRITE(11) "first"
  WRITE(11) "second"
  WRITE(11) 7
  READ(11, POS=3) string
  READ(11, POS=12) n
  if (string.ne."rst") call abort()
  if (n.ne.7) call abort()
  close(unit=11, status="delete")
END PROGRAM readUstream

max_stars_repo_name: vidkidz/crossbridge

max_issues_repo_name: vidkidz/crossbridge

max_forks_repo_name: vidkidz/crossbridge


SUBROUTINE yaw_angle (e_BX, v_sat, beta, satblk, Yangle)

! ----------------------------------------------------------------------
! SUBROUTINE: yaw_angle.f90
! ----------------------------------------------------------------------
! Purpose:
!  Computation of the Yaw angle based on the Body-X unit vector
! (as computed by the eclips.f subroutine) and the satellite velocity vector.
!
!  The sign of the Yaw angle follows the convections of the eclips.f
! ----------------------------------------------------------------------
! Input arguments:
! - eB_X: 			Satellite Body-X unit vector (m)
! - v_sat: 			Satellite velocity vector (m/sec)
! - r_sun:			Sun position vector (m)
! - beta:			Sun angle with the orbital plane in degrees (see Note 1)
! - satblk:			Satellite Block series number 1=I, 2=II, 3=IIA, IIR=(4,5) IIF=6
!
! Output arguments:
! - Yangle:			Yaw angle (in degrees)
! ----------------------------------------------------------------------
! Note 1:
!  Beta angle is computed by the beta_angle.f90 subroutine
! ----------------------------------------------------------------------
! Dr. Thomas D. Papanikolaou, Geoscience Australia             June 2016
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_d), INTENT(IN) :: e_BX(3), v_sat(3), beta
      !INTEGER (KIND = prec_int4), INTENT(IN) :: satblk
      INTEGER, INTENT(IN) :: satblk

! OUT
      REAL (KIND = prec_d), INTENT(OUT) :: Yangle
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration

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

! ----------------------------------------------------------------------
! Yaw angle computation (in degrees)
! ----------------------------------------------------------------------

      Yangle = acos( (e_BX(1) * v_sat(1) + e_BX(2) * v_sat(2) + e_BX(3) * v_sat(3)) &
	                  / sqrt(v_sat(1)**2 + v_sat(2)**2 + v_sat(3)**2) ) &
					 * (180D0 / PI_global)

! Yaw angle sign (according to eclips.f convenctions)

! IIR YANGLE has the same sign as beta, II/IIA has the opposite sign
      if (beta .LT. 0.d0 .AND. satblk .GE. 4 .AND. satblk .LE. 5) then
          Yangle = -Yangle
      end if

      if (beta .GT. 0.d0 .AND. satblk .NE. 4 .AND. satblk .NE. 5) then
          Yangle = -Yangle
      end if
! ----------------------------------------------------------------------

END


text:
! from NIST test FM406.FOR
         CHARACTER*10 A10VK
         A10VK = 'XXXXXXXXXX'
         WRITE(A10VK,39110)
39110    FORMAT()
!
!  the empty format should fill the target of the internal
!  write with blanks.
!
         IF (A10VK.NE.'') THEN
!          PRINT*,A10VK
           CALL ABORT
         ENDIF
         END


text:
	SUBROUTINE IN_HILO ( hilo, icolr, csymbl, isymbl, isymtp,
     +			     valflg, iprecn, range, krad, knt,
     +			     intflg, iret )
C************************************************************************
C* IN_HILO								*
C*									*
C* This subroutine scans the user input for HILO.  This consists of	*
C* six input strings separated by slashes.  When a string can be two	*
C* substrings separated by a semicolon, the first substring applies	*
C* to highs, the second to lows.  If no substring is given a default	*
C* is provided.  The table below summarizes the input format and	*
C* gives the defaults.							*
C*									*
C*  STRING	Description        Format      Example     Default	*
C*    1       Color number          i;i           1           0		*
C*    2       Symbol#precision    c#i;c#i      H#2;L#1       H;L	*
C*    3       Range               i-i;i-i       30-40      0-0;0-0	*
C*    4       Search radius	     i            4           3		*
C*    5       Count                 i;i		10;5	    20;20	*
C*    6       Interpolation flag     l            T           F		*
C*									*
C* If the first string is a single number, that number is the color	*
C* number for both highs and lows.  In the second string, the c in the	*
C* table stands for either a character string, or a marker or special 	*
C* symbol number. Special symbols are specified by preceeding the 	*
C* number with an 'S'. The # sign is a flag to plot the values beneath 	*
C* the marker.  The number following # is the number of decimal places	*
C* to display in the value.  If the number is absent, integer values are*
C* displayed.								*
C*									*
C* The defaults above apply if no string is entered.  If one of the	*
C* entries of a string is entered, it is assumed to apply to highs	*
C* unless it is preceded by a semicolon.  The omitted entry defaults	*
C* according to the table below:					*
C*									*
C*    STRING          DEFAULT FOR OMITTED PART				*
C*       1		   Same value					*
C*	 2		   No symbol					*
C*	 3		   Missing values				*
C*	 5		   Same value					*
C*									*
C* All of the output parameters except KRAD and INTFLG involve outputs	*
C* for both highs and lows.  The first output is always for highs.	*
C* For example, ISYMBL (1) is for highs; ISYMBL (2) is for lows.	*
C*									*
C*									*
C* IN_HILO ( HILO, ICOLR, CSYMBL, ISYMBL, ISYMTP, VALFLG, IPRECN,	*
C*	     RANGE, KRAD, KNT, INTFLG, IRET )				*
C*									*
C* Input parameters:							*
C*	HILO		CHAR*		User input			*
C*									*
C* Output parameters:							*
C*	ICOLR  (2)	INTEGER		Color number			*
C*	CSYMBL (2)	CHAR*		Symbol string			*
C*	ISYMBL (2)	INTEGER		Marker number			*
C*	ISYMTP (2)	INTEGER		Symbol type			*
C*					  0 = NONE			*
C*					  1 = CHARACTERS		*
C*					  2 = Marker number		*
C*					  3 = Special symbol number	*
C*	VALFLG (2)	LOGICAL		Flag to plot value		*
C*	IPRECN (2)	INTEGER		Number of decimal places	*
C*	RANGE  (4)	REAL		Range for maxima and minima	*
C*					  RANGE (1) = min for max	*
C*					  RANGE (2) = max for max	*
C*					  RANGE (3) = min for min	*
C*					  RANGE (4) = max for min	*
C*	KRAD		INTEGER		Search radius			*
C*	KNT    (2)	INTEGER		Maximum number to find		*
C*	INTFLG		LOGICAL		Flag to interpolation		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* K. Brill/NMC		01/93						*
C* S. Jacobs/NMC	10/94	Parse the range with ST_RANG		*
C* D. Keiser/GSC	11/95	Incr. dimension of variable part	*
C* S. Jacobs/NCEP	 4/96	Parse colors using IN_COLR		*
C* G. Krueger/EAI	 8/96	Fix no semicolon cases			*
C* M. Linda/GSC		10/97	Corrected the prologue format		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER* (*)	hilo, csymbl (2)
	INTEGER		icolr (2), isymbl (2), isymtp (2), knt (2),
     +			iprecn (2)
	REAL		range (4)
	LOGICAL		valflg (2), intflg
C*
	CHARACTER	strngs(6)*32, part(2)*50, subprt(2)*8,
     +			first*8, last*8, inc*8
C------------------------------------------------------------------------
	iret  = 0
C
C*	Split the input into six substrings.
C
	CALL ST_CLST ( hilo, '/', ' ', 6, strngs, num, ier )
C
C*	Get the color numbers.
C
	isemi = INDEX ( strngs (1), ';' )
	IF  ( isemi .eq. 0 )  THEN
	    IF  ( strngs (1) .eq. ' ' )  THEN
		icolr (1) = 0
		icolr (2) = 0
	      ELSE
		CALL IN_COLR ( strngs (1), 1, icolr, ier )
		icolr (2) = icolr (1)
	    END IF
	  ELSE
	    CALL IN_COLR ( strngs (1), 2, icolr, ier )
	END IF
C
	IF  ( ( icolr (1) .eq. 0 ) .and. ( icolr (2) .eq. 0 ) ) RETURN
C
C*	Get the symbol type and set flag for plotting the value.
C
	isemi = INDEX ( strngs (2), ';' )
	IF ( isemi .eq. 0 ) THEN
	    IF ( strngs (2) .eq. ' ' ) THEN
		strngs (2) = 'H;L'
	    ELSE
		CALL ST_LSTR ( strngs (2), lenstr, ier )
		strngs (2) = strngs (2) (1:lenstr) // ';' // strngs (2)
	    END IF
	END IF
C
	CALL ST_CLST ( strngs (2), ';', ' ', 2, part, num, ier )
	DO i = 1, 2
	    CALL ST_CLST ( part (i), '#', ' ', 2, subprt, npp, ier )
	    CALL ST_NUMB ( subprt (1), ival, ier )
	    CALL ST_NUMB ( subprt (1)(2:), ivalm, ierm )
	    IF ( ier .eq. 0 ) THEN
		csymbl (i) = ' '
		isymbl (i) = ival
		isymtp (i) = 2
	    ELSE IF ( ierm .eq. 0 ) THEN
		csymbl (i) = ' '
		isymbl (i) = ivalm
		CALL ST_LCUC ( subprt (1)(1:1), first, ier )
		IF ( first .eq. 'S' )  THEN
		    isymtp (i) = 3
		ELSE
		    isymtp (i) = 2
		END IF
	    ELSE IF ( subprt (1) .ne. ' ' ) THEN
	        csymbl (i) = subprt (1)
		isymbl (i) = IMISSD
	        isymtp (i) = 1
	    ELSE
		csymbl (i) = ' '
		isymbl (i) = IMISSD
		isymtp (i) = 0
	    END IF
	    IF ( INDEX ( part (i), '#' ) .eq. 0 ) THEN
		valflg (i) = .false.
		iprecn (i) = 0
	    ELSE
		valflg (i) = .true.
		CALL ST_NUMB ( subprt (2), ival, ier )
		IF ( ier .eq. 0 ) THEN
		    iprecn (i) = ival
		ELSE
		    iprecn (i) = 0
		END IF
	    END IF
	    IF  ( iprecn(i) .lt. 0 )  iprecn(i) = 0
	    IF  ( iprecn(i) .gt. 9 )  iprecn(i) = 9
	END DO
C
C*	Get the range.
C
	IF ( ( strngs (3) .eq. 'all' .or. strngs (3) .eq. 'ALL' )
     +	    .or. strngs (3) .eq. ' ' ) THEN
	    DO i = 1, 4
		range (i) = 0.0
	    END DO
	ELSE
C
	    isemi = INDEX ( strngs (3), ';' )
	    IF ( isemi .eq. 0 ) THEN
		CALL ST_LSTR ( strngs (3), lenstr, ier )
		strngs (3) = strngs (3) (1:lenstr) // ';' // strngs (3)
	    END IF
	    CALL ST_CLST ( strngs (3), ';', ' ', 2, part, num, ier )
	    DO i = 1, num
		indx = (i - 1) * 2 + 1
		CALL ST_RANG ( part (i), first, last, inc, itype, ier )
		CALL ST_CRNM ( first, val, ier )
		IF ( ier .ne. 0 ) val = 0
		range (indx) = val
		indx = indx + 1
		CALL ST_CRNM ( last, val, ier )
		IF ( ier .ne. 0 ) val = 0
		range (indx) = val
		indx = indx + 1
	    END DO
	    save = range (1)
	    range (1) = MIN ( range (1), range (2) )
	    range (2) = MAX ( save, range (2) )
	    save = range (3)
	    range (3) = MIN ( range (3), range (4) )
	    range (4) = MAX ( save, range (4) )
	END IF
C
C*	Get the search radius.
C
	CALL ST_CRNM ( strngs (4), val, ier )
	IF ( val .le. 0 .or. ier .ne. 0 ) THEN
	    krad = 3
	ELSE
	    krad = val
	END IF
C
C*	Get the maximum count for extrema.
C
	CALL ST_ILST ( strngs (5), ';', 20, 2, knt, nn, ier )
	IF ( ier .ne. 0 ) THEN
	    knt (1) = 20
	    knt (2) = 20
	END IF
	IF ( nn .eq. 1 ) knt (2) = knt (1)
C
C*	Get the interpolation flag.
C
	IF ( strngs (6) (1:1) .eq. 'y' .or. strngs (6) (1:1)
     +	     .eq. 'Y' ) THEN
	    intflg = .true.
	ELSE
	    intflg = .false.
	END IF
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
	SUBROUTINE AF_TMPC  ( csign, ctmpc, iret )
C************************************************************************
C* AF_TMPC								*
C*									*
C* This subroutine decodes and stores the temperature from AMDAR,	*
C* AIREP, and PIREP reports.						*
C*									*
C* AF_TMPC  ( CSIGN, CTMPC, IRET )					*
C*									*
C* Input parameters:							*
C*	CSIGN		CHAR*		Encoded	sign of temperature 	*
C*	CTMPC		CHAR*		Encoded temperature 		*
C*									*
C* Output parameters:							*
C*	RIVALS (IRTMPC)	REAL		Temperature in Celsius		*
C*	IRET		INTEGER		Return code 			*
C*					  0 = normal return 		*
C*					 -1 = error during decoding	*
C*									*
C**									*
C* Log:									*
C* J. Ator/NP12		09/96						*
C* J. Ator/NP12		03/97	Reject 3-digit temperatures within AIREP*
C* J. Ator/NP12		08/97	New interface format, style changes	*
C* J. Ator/NCEP		09/99	Allow 1-digit temperatures within PIREP	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'afcmn.cmn'
C*
	CHARACTER*(*)	csign, ctmpc
C*
	INCLUDE		'ERMISS.FNC'
C-----------------------------------------------------------------------
C
C*	Initialize variables.
C
	iret = 0
	rmult = RMISSD
	rdiv = RMISSD
	tmpc = RMISSD
C
C*	Determine the length of the input temperature string.
C
	lctmpc = LEN ( ctmpc )
	IF  ( ( lctmpc .eq. 3 ) .and. ( bultyp .ne. AIREP ) )  THEN
	    rdiv = 10.0
	ELSE IF  ( ( lctmpc .eq. 2 ) .and. ( bultyp .ne. AMDAR ) )  THEN
	    rdiv = 1.0
	ELSE IF  ( ( lctmpc .eq. 1 ) .and. ( bultyp .eq. PIREP ) )  THEN
	    rdiv = 1.0
	END IF
C
C*	Determine the length of the input temperature sign string,
C*	and then decode the sign of the temperature accordingly.
C
	lcsign = LEN ( csign )
	IF  ( lcsign .eq. 2 )  THEN
	    IF  ( csign (1:2) .eq. 'PS' )  THEN
		rmult = 1.0
	    ELSE IF  ( csign (1:2) .eq. 'MS' )  THEN
		rmult = -1.0
	    END IF
	ELSE IF  ( ( lcsign .eq. 1 ) .and. ( bultyp .ne. AMDAR ) )  THEN
	    IF  ( ( csign (1:1) .eq. 'P' ) .or.
     +		  ( csign (1:1) .eq. '+' ) )  THEN
		rmult = 1.0
	    ELSE IF  ( ( csign (1:1) .eq. 'M' ) .or.
     +		       ( csign (1:1) .eq. '-' ) )  THEN
		rmult = -1.0
	    END IF
	END IF
C
	IF  (  ( .not. ( ERMISS ( rmult ) ) ) .and.
     +	       ( .not. ( ERMISS ( rdiv ) ) )  )  THEN
C
C*	    Decode the temperature.
C
	    CALL ST_INTG  ( ctmpc (1:lctmpc), itmpc, ier )
	    IF  ( ier .eq. 0 )  THEN
		tmpc = ( FLOAT ( itmpc ) * rmult ) / rdiv
	    END IF
	END IF
C
	IF  ( ERMISS ( tmpc ) )  THEN
	    logmsg = 'temperature '  //  csign (1:lcsign)  //
     +			ctmpc (1:lctmpc)
	    CALL DC_WLOG  ( 2, 'AF', 2, logmsg, ierwlg )
	    iret = -1
	ELSE
C
C*	    Store the temperature.
C
	    rivals ( irtmpc ) = tmpc
	END IF
C*
	RETURN
	END


text:
SUBROUTINE readbc(bcfile)

!-------------------------------------------------------------
!
! Reads the incoming angular flux from the input file
!
!-------------------------------------------------------------

USE invar
USE totvar
IMPLICIT NONE
CHARACTER(8), INTENT(IN) :: bcfile
INTEGER :: n, i, o

! Allocate the size of the vectors for each quadrant from the dimensions and
! angular order of the problem
ALLOCATE(posiny(nxt,apo,2), neginy(nxt,apo,2))
ALLOCATE(posinx(nyt,apo,2), neginx(nyt,apo,2))

posiny = 0.0
neginy = 0.0
posinx = 0.0
neginx = 0.0

! Open the BC data file to be read
! Only need to open file if one of the quadrants has angular flux inward
IF (MAXVAL(bc) == 2) THEN
   OPEN(UNIT=14, FILE=bcfile)
   ! Read first dummy line of file
   READ(14,*)       ! Dummy line
END IF

! Read the BC data from the file
! Eventually these matrices will be put into single vectors that go ybc,
! xbc. Within each set of those it goes by angle, then by cell.
! There will be a vector for each quadrant.
! For now, keep it as a matrix for each face: +Y, -Y, +X, -X
! Read values for the four quadrants of each face in increasing order of 1-4. 1-4 are positive
! z direction + trig setup of quadrants.
IF (bc(1) == 2) THEN
   DO o = 1, 2     ! Actual octants 1, 2
      DO n = 1, apo
         READ(14,*)
         DO i = 1, nxt
            READ(14,*) posiny(i,n,o)
         END DO
      END DO
   END DO
END IF
IF (bc(2) == 2) THEN
   DO o = 1, 2     ! Actual octants 3, 4
      DO n = 1, apo
         READ(14,*)
         DO i = 1, nxt
            READ(14,*) neginy(i,n,o)
         END DO
      END DO
   END DO
END IF
IF (bc(3) == 2) THEN
   DO o = 1, 2     ! Actual octants 1, 4
      DO n = 1, apo
         READ(14,*)
         DO i = 1, nyt
            READ(14,*) posinx(i,n,o)
         END DO
      END DO
   END DO
END IF
IF (bc(4) == 2) THEN
   DO o = 1, 2     ! Actual octants 2, 3
      DO n = 1, apo
         READ(14,*)
         DO i = 1, nyt
            READ(14,*) neginx(i,n,o)
         END DO
      END DO
   END DO
END IF

! Check that all the input angular fluxes are non-negative
IF (MINVAL(posiny) < 0.0 .OR. MINVAL(neginy) < 0.0) THEN
   warn = warn + 1
   WRITE(8,'(/,3X,A,/)') "WARNING: YBC angular flux from input should be zero or greater"
END IF
IF (MINVAL(posinx) < 0.0 .OR. MINVAL(neginx) < 0.0) THEN
   warn = warn + 1
   WRITE(8,'(/,3X,A,/)') "WARNING: XBC angular flux from input should be zero or greater"
END IF

CLOSE(14)

RETURN
END SUBROUTINE readbc

max_stars_repo_name: lanl/pidots

max_issues_repo_name: lanl/pidots

max_forks_repo_name: lanl/pidots


text:
!   gfortran -cpp -O3 -flto ex_6.f90 -o ex_6
!   ./ex_6

!   1d scalar transport in a periodic domain. Fluxes are
!   computed in a flux-form semi-lagrangian sense --
!   integrating over the upwind regions "swept" by edges
!   in each time-step. This implementation requires CFL<1,
!   with the upwind regions covering adjacent cells only.
!   A CFL>=1 variant could be constructed using RMAP1D().
!

#   include "../src/ppr_1d.f90"

    program ex

        use ppr_1d

        implicit none

        integer, parameter :: halo = 4  ! halo cells at boundary
        integer, parameter :: npos = 51 ! no. edge
        integer, parameter :: nvar = 1  ! no. tracers to trnsprt
        integer, parameter :: ndof = 1  ! no. FV DoF per cell
        integer :: ipos,il,ir,step

    !------------------------------- domain discretisation !
        real*8  :: xpos(1-halo:npos+halo)
        real*8  :: xmid,xdel(1),tDEL

    !-------------------------------- finite-volume arrays !

    !   INIT: initial cell-wise finite-volume profile
    !   QBAR: dynamic cell-wise finite-volume profile
    !   MASK: cell-wise "land" mask (all TRUE here)
    !   UVEL: edge-wise velocity distribution
    !   FLUX: edge-wise distribution of upwind fluxes
    !   QDIV: cell-wise distribution of divergence

        real*8  :: init(ndof,nvar,1-halo:npos+halo-1)
        real*8  :: qbar(ndof,nvar,1-halo:npos+halo-1)
        logical :: mask(          1-halo:npos+halo-1)
        real*8  :: uvel(          1-halo:npos+halo)
        real*8  :: flux(     nvar,1-halo:npos+halo)
        real*8  :: qdiv(     nvar,1-halo:npos+halo-1)

    !------------------------------ method data-structures !
        type(rmap_work) :: work
        type(rmap_opts) :: opts
        type(rcon_ends) :: bc_l(nvar)
        type(rcon_ends) :: bc_r(nvar)

    !------------------------------ define a simple domain !

        il =      + 1                   ! 1st real interior cell
        ir = npos - 1                   ! Nth real interior cell

        xpos(il+0) = 0.0d+00
        xpos(ir+1) = 1.0d+00

        xdel(1) = (xpos(ir+1)-xpos(il+0))/(npos-1)

        do ipos = il+1, ir-0

            xpos(ipos) = (ipos-1) * xdel(1)

        end do

    !------------------------------ setup some simple data !

        uvel       = +1.0d+0
        mask       = .true.

        tDEL       = +1.0d-2

        do ipos = +1, npos-1

            xmid = xpos(ipos+0)* 0.5d+00 &
    &            + xpos(ipos+1)* 0.5d+00

            init(1,1,ipos) = &
    &   .8d+0 * exp( -75.0d+0 * (xmid - 0.275d+0) ** 2 ) &
    & + .9d+0 * exp(-100.0d+0 * (xmid - 0.500d+0) ** 2 ) &
    & + 1.d+0 * exp(-125.0d+0 * (xmid - 0.725d+0) ** 2 )

        end do

    !------------------------------ specify method options !

        opts%edge_meth = p3e_method     ! 3rd-order edge interp.
        opts%cell_meth = ppm_method     ! PPM method in cells
        opts%cell_lims = weno_limit     ! "non-oscillatory" lim.

    !------------------------------ set BC.'s at endpoints !

        bc_l%bcopt = bcon_loose         ! "loose" = extrapolate
        bc_r%bcopt = bcon_loose

    !------------------------------ init. method workspace !

        call work%init(npos+2*halo,nvar,opts)

    !------------------------------ calc. scalar transport !

        qbar = init

        do step = +1, +100        ! 100 steps => full loop

    !------------------------------ periodicity via halo's !

            qbar(1,:,il-halo:il-1) = &
    &       qbar(1,:,ir-halo+1:ir)
            qbar(1,:,ir+1:ir+halo) = &
    &       qbar(1,:,il:il+halo-1)

    !------------------------------ form lagrangian fluxes !

            call ffsl1d (npos+2*halo,nvar, &
    &            ndof,xdel,tDEL,mask,uvel, &
    &            qbar,flux,bc_l,bc_r,work, &
    &            opts)

    !------------------------------ flux divergence eval's !
            qdiv(  1,il:ir) = &
    &              flux(1,il+1:ir+1) &
    &            - flux(1,il+0:ir+0)

    !------------------------------ take a single timestep !

            qbar(1,1,il:ir) = &
    &           qbar(1,1,il:ir) - &
    &               qdiv(1,il:ir) / xdel(1)

        end do

    !------------------------------ clear method workspace !

        call work%free()

    !------------------------------ dump results to stdout !

        print*,"End timestep profile : "

        do ipos = il+0, ir-0

            print *, init(1,:,ipos)  &
    &              , qbar(1,:,ipos)

        end do

        print*,"Conservation defect := " &
    &         , sum(init(1,:,il:ir)) &
    &         - sum(qbar(1,:,il:ir))

    end program

max_stars_repo_name: mark-petersen/PPR

max_issues_repo_name: mark-petersen/PPR

max_forks_repo_name: mark-petersen/PPR


text:
      subroutine ptztab(iopr,narn1,narn2,natmax,nmutmx,nmux,nmxi,
     $ nmxmax,nmxx,noprmx,noutpt,nsltmx,nslx,nstmax,nsxi,nsxmax,
     $ nsxx,uspec)
c
c     This subroutine tabulates the species combinations corresponding
c     to coefficients for Pitzer's equations. The tabulation is
c     controlled by iopr(10):
c
c        0 = Don't print
c        1 = Print a summary of the names of the species present and
c              the number of Pitzer interaction coefficients
c        2 = Print a summary of the names of the species present and
c              the number of Pitzer interaction coefficients
c
c     This subroutine is called by:
c
c       EQ3NR/eq3nr.f
c       EQ6/eq6.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c       iopr   = array of print option switches
c       narn1  = start of aqueous species range
c       narn2  = end of aqueous species range
c       nmux   = array of aqueous species indices defining triplets
c                  of species for which mu data are present
c       nmutmx = the maximum number of triplets of aqueous species
c                  for which Pitzer interaction parameters are
c                  defined; the second dimension of the nmux array
c       nmxi   = range pointer array into the nmxx array:
c                  nmxi(1,na) and nmxi(2,na) are the first and last
c                  values of the second subscript (nmx) of the nmxx
c                  array for entries pertaining to the na-th
c                  aqueous species (ns-th species)
c       nmxx   = pointer array:
c                  nmxx(1,nmx) = the species index of the second
c                  species in the nmu-th triplet, nmxx(2,nmx) is the
c                  species index of the third species, and
c                  nmxx(3,nmx) = nmu
c       nslx   = array of aqueous species indices defining pairs
c                  of species for which S-lambda data are present
c       nsltmx = the maximum number of pairs of aqueous species
c                  for which Pitzer interaction parameters are
c                  defined; the second dimension of the nslx array
c       nsxi   = range pointer array into the nsxx array:
c                  nsxi(1,na) and nsxi(2,na) are the first and last
c                  values of the second subscript (nsx) of the nsxx
c                  array for entries pertaining to the na-th
c                  aqueous species (ns-th species)
c       nsxx   = pointer array:
c                  nsxx(1,nsx) = the species index of the second
c                  species in the nsl-th pair, and nsxx(2,nsx) = nsl
c       uspec  = names of species
c
c     Principal output:
c
c        None
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer natmax,nmutmx,nmxmax,noprmx,nsltmx,nstmax,nsxmax
c
      integer noutpt
c
      integer iopr(noprmx),nmux(3,nmutmx),nmxi(2,natmax),nmxx(3,nmxmax),
     $ nslx(2,nsltmx),nsxi(2,natmax),nsxx(2,nsxmax)
      integer narn1,narn2
c
      character*48 uspec(nstmax)
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer j2,j3,j4,islt,imut,ixf,ixl,na,nmu,nmx,ns,nsl,nsx,ns1,
     $ ns2,ns3
c
      integer ilnobl
c
c-----------------------------------------------------------------------
c
      if (iopr(10) .le. 0) go to 999
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     The following loop assumes that water is the narn1-th species.
c
      if (iopr(10) .eq. 1) then
c
c       Write a table giving the S-lambda and mu tallies for each
c       aqueous species in the current model.
c
        write (noutpt,1000)
 1000   format(/11x,'--- Pitzer Interaction Coefficient Summary ---',
     $  /4x,'Species',15x,'S-lambda Sets',3x,'Mu Sets',/)
c
c       The following loop assumes that water is the narn1-th species.
c
        do ns = narn1 + 1, narn2
          if (uspec(ns)(1:6).ne.'O2(g) ' .and.
     $      uspec(ns)(1:3).ne.'e- ') then
            na = ns - narn1 + 1
            islt = nsxi(2,na) - nsxi(1,na) + 1
            imut = nmxi(2,na) - nmxi(1,na) + 1
            write (noutpt,1010) uspec(ns),islt,imut
 1010       format(2x,a24,2x,i4,7x,i4)
          endif
        enddo
        write (noutpt,1020)
 1020   format(/1x)
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      if (iopr(10) .ge. 2) then
c
c       Write a table giving the S-lambda and mu tallies for eachi
c       aqueous species in the current model. Also list the other
c       species involved in the S-lambda and mu combinations.
c
        write (noutpt,1100)
 1100   format(/15x,'--- Pitzer Interaction Coefficient Sets ---')
c
c       The following loop assumes that water is the narn1-th species.
c
        do ns = narn1 + 1, narn2
          if (uspec(ns)(1:6).ne.'O2(g) ' .and.
     $      uspec(ns)(1:3).ne.'e- ') then
            na = ns - narn1 + 1
            j2 = ilnobl(uspec(ns)(1:24))
            write (noutpt,1110) uspec(ns)(1:j2)
 1110       format(//' Coefficients for ',a,':',/)
c
            ixf = nsxi(1,na)
            ixl = nsxi(2,na)
            islt = ixl - ixf + 1
            write (noutpt, 1120) islt
 1120       format(3x,'No. of S-lambda sets= ',i4,':',/)
            if (islt .gt. 0) then
              do nsx = ixf,ixl
                nsl = nsxx(2,nsx)
                ns1 = nslx(1,nsl)
                ns2 = nslx(2,nsl)
                j2 = ilnobl(uspec(ns1)(1:24))
                j3 = ilnobl(uspec(ns2)(1:24))
                write (noutpt,1130) uspec(ns1)(1:j2),uspec(ns2)(1:j3)
 1130           format(5x,a,', ',a)
              enddo
            endif
c
            ixf = nmxi(1,na)
            ixl = nmxi(2,na)
            imut = ixl - ixf + 1
            write (noutpt, 2530) imut
 2530       format(/3x,'No. of mu sets= ',i4,':',/)
            if (imut .gt. 0) then
              do nmx = ixf,ixl
                nmu = nmxx(3,nmx)
                ns1 = nmux(1,nmu)
                ns2 = nmux(2,nmu)
                ns3 = nmux(3,nmu)
                j2 = ilnobl(uspec(ns1)(1:24))
                j3 = ilnobl(uspec(ns2)(1:24))
                j4 = ilnobl(uspec(ns3)(1:24))
                write (noutpt,2540) uspec(ns1)(1:j2),uspec(ns2)(1:j3),
     $          uspec(ns3)(1:j4)
 2540           format(5x,a,', ',a,', ',a)
              enddo
            endif
c
          endif
        enddo
        write (noutpt,1020)
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
  999 continue
      end


text:
*$ Section 2: Data analysis routines
*  ---------------------------------

*+ utl_linfit

       subroutine utl_linfit (npts,x,y,sigmay,a,sigmaa,b,sigmab,chi2)
C      --------------------------------------------------------------
C
C Fit a straigth-line to the specified data
C
C Given:
C   number of data points
       integer  npts
C   input x, y data
       real*4   x(npts), y(npts)
C   error in Y-data
       real*4   sigmay(npts)
C Returned:
C   results of regression
       real*4   a, b
C   error on regression results
       real*4   sigmaa, sigmab
C   Chi**2
       real*4   chi2
C
C
C      P.R.Bevington (1969) "Data reduction and Error analysis
C                            for the Phyiscal sciences"
C      modified by J.P.Leahy, 18/7/83
C     Purpose:
C       make a least-squares fit to data with a straight line
C          Y = A + B*X
C-
      real sumw, sumx, sumy, sumx2, sumxy, weight, delta
      integer i

      sumw = 0.0
      sumx = 0.0
      sumy = 0.0
      sumx2 = 0.0
      sumxy = 0.0
      chi2 = 0.0
C
C        Accumulate weighted sums.
C
      do 50  i = 1,npts
        if (sigmay(i) .gt. 1e-4) goto 10
          write (6,6099) y,sigmay
 6099       format (10(' ',f9.5))
          chi2 = 100
          a = 0
          b = 0
          sigmaa = 0
          sigmab = 0
          goto 200
 10     weight = 1.0 / sigmay(i)**2
        sumw = sumw + weight
        sumx = sumx + weight * x(i)
        sumy = sumy + weight * y(i)
        sumx2 = sumx2 + weight * x(i)**2
        sumxy = sumxy + weight * x(i)*y(i)
 50   continue
C
C        Calculate coefficients and standard deviations.
C
      delta = sumw*sumx2 - sumx**2
      a = (sumx2*sumy - sumx*sumxy) / delta
      b = (sumxy*sumw - sumx*sumy ) / delta
      sigmaa = sqrt( sumx2 / delta )
      sigmab = sqrt( sumw  / delta )
      do 100  i = 1,npts
        chi2 = chi2 + ((a+b*x(i) - y(i)) / sigmay(i))**2
 100  continue
 200  return
      end

max_stars_repo_name: CavendishAstrophysics/anmap

max_issues_repo_name: CavendishAstrophysics/anmap

max_forks_repo_name: CavendishAstrophysics/anmap


text:
C    Copyright(C) 2014-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
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

C $Id: pline.f,v 1.4 2001/11/05 13:26:52 gdsjaar Exp $
C $Log: pline.f,v $
C Revision 1.4  2001/11/05 13:26:52  gdsjaar
C  Fixed array boundary problem in region check code.
C
C Revision 1.3  1998/07/14 18:19:37  gdsjaar
C Removed unused variables, cleaned up a little.
C
C Changed BLUE labels to GREEN to help visibility on black background
C (indirectly requested by a couple users)
C
C Revision 1.2  1991/03/21 15:45:09  gdsjaar
C Changed all 3.14159... to atan2(0.0, -1.0)
C
c Revision 1.1.1.1  1990/11/30  11:13:41  gdsjaar
c FASTQ Version 2.0X
c
c Revision 1.1  90/11/30  11:13:39  gdsjaar
c Initial revision
c
C
CC* FILE: [.QMESH]PLINE.FOR
CC* MODIFIED BY: TED BLACKER
CC* MODIFICATION DATE: 7/6/90
CC* MODIFICATION: COMPLETED HEADER INFORMATION
C
CC* MODIFIED BY: TED BLACKER
CC* MODIFICATION DATE: 7/31/90
CC* MODIFICATION: ADDED ARGUMENTS TO CALL TO PLINE TO PASS MINIMUM
CC**              ELEMENT SIZE (SIZMIN) AND GETSIZ PARAMETERS OF
CC**              EMIN AND EMAX
C
      SUBROUTINE PLINE (MP, ML, MAXNP, MAXNBC, MAXSBC, IPOINT,
     &   COOR, LINKP, KNUM, KT, NINT, FAC, IP1, IP2, IP3, X, Y, NID,
     &   IPBC1, IPBC2, ILBC, ISBC, LINKPB, NPPF, IFPB, LISTPB, LINKLB,
     &   NLPF, IFLB, LISTLB, LINKSB, NSPF, IFSB, LISTSB, LSTNBC, KNBC,
     &   KSBC, ERR, TEST, REAL, COUNT, NOROOM, AMESUR, XNOLD, YNOLD,
     &   NXKOLD, MMPOLD, LINKEG, LISTEG, BMESUR, MLINK, NPROLD, NPNOLD,
     &   NPEOLD, NNXK, REMESH, REXMIN, REXMAX, REYMIN, REYMAX, IDIVIS,
     &   SIZMIN, EMAX, EMIN, GRAPH, DXMAX)
C***********************************************************************
C
C  SUBROUTINE PLINE = PRODUCES A NODE STRING FOR THE K'TH LINE IN THE
C                     LINE TABLE
C
C***********************************************************************
C
C  VARIABLES USED:
C     NID   = AN ARRAY OF UNIQUE NODE IDENTIFIERS.
C     REAL  = .TRUE. FOR AN ACTUAL GENERATION
C           = .FALSE. FOR A TRIAL GENERATION
C     ERR   = .TRUE. IF AN ERROR WAS ENCOUNTERED
C     IP1   = POINTER FOR THE FIRST POINT
C     IP2   = POINTER FOR THE SECOND POINT
C     IP3   = POINTER FOR THE THIRD POINT
C     MAXNP = MAXIMUM NUMBER OF NODES ON THE PERIMETER
C     NOTE: MAXNP MUST BE ADJUSTED FOR THE CURRENT LOCATION
C           IN X, Y, &NID
C     KT    = THE LINE TYPE:
C           = 1 FOR STRAIGHT LINES
C           = 2 FOR CORNER LINES
C           = 3 FOR ARC WITH CENTER GIVEN
C           = 4 FOR ARC WITH THIRD POINT ON THE ARC
C           = 5 FOR PARABOLA
C           = 6 FOR ARC WITH RADIUS GIVEN
C
C***********************************************************************
C
      DIMENSION IPOINT (MP), COOR (2, MP), LINKP (2, MP)
      DIMENSION X (MAXNP), Y (MAXNP), NID (MAXNP)
      DIMENSION LINKPB (2, MP), NPPF (MP), IFPB (MP), LISTPB (2, MP)
      DIMENSION LINKLB (2, ML), NLPF (ML), IFLB (ML), LISTLB (2, ML)
      DIMENSION LINKSB (2, ML), NSPF (ML), IFSB (ML), LISTSB (2, ML)
      DIMENSION LSTNBC (MAXNBC)
C
      DIMENSION AMESUR(NPEOLD), XNOLD(NPNOLD), YNOLD(NPNOLD)
      DIMENSION NXKOLD(NNXK, NPEOLD), MMPOLD(3, NPROLD)
      DIMENSION LINKEG(2, MLINK), LISTEG(4 * NPEOLD), BMESUR(NPNOLD)
C
      LOGICAL ERR, REAL, TEST, ADDLNK, COUNT, NOROOM, REMESH
      LOGICAL GRAPH
C
      PI = ATAN2(0.0, -1.0)
C
      EPS = .01
      ERR = .FALSE.
      ADDLNK = .FALSE.
      NOROOM = .FALSE.
      TWOPI  =  PI + PI
C
C     COMPUTE FRACTION OF TOTAL LENGTH FOR FIRST INTERVAL
C
      N = IABS (NINT) + 1
      IF (N .LE. 1)THEN
         WRITE (*, 10000)KNUM
         ERR = .TRUE.
         GOTO 340
      ENDIF
      IF (N .GT. MAXNP) THEN
        WRITE (*,*) 'INTERNAL ERROR: Intervals exceed space'
        STOP
      END IF

      DFF = 1.0/DBLE(N - 1)
      IF (ABS (1.0 - FAC) .GT. 1.0E-6)
     &   DFF =  (FAC - 1.0)/ (FAC ** (N - 1) - 1.0)
C
C  DEFINE FIRST POINT EXACTLY AND BRANCH
C
      X (1) = COOR (1, IP1)
      Y (1) = COOR (2, IP1)
      IF (N .GT. 2)THEN
C
C  STRAIGHT LINE GENERATION
C
         IF (KT .EQ. 1)THEN
            YDIFF = COOR (2, IP2) - COOR (2, IP1)
            XDIFF = COOR (1, IP2) - COOR (1, IP1)
            D = SQRT (YDIFF **2 + XDIFF **2)
            IF (D .EQ. 0.)THEN
               WRITE (*, 10010)KNUM
               ERR = .TRUE.
               GOTO 340
            ENDIF
            IF (REMESH) THEN
CC* MODIFIED BY: TED BLACKER
CC* MODIFICATION DATE: 7/31/90
CC* MODIFICATION: ADDED ARGUMENTS TO CALL TO STRSIZ TO PASS MINIMUM
CC**              ELEMENT SIZE (SIZMIN) AND GETSIZ PARAMETERS OF
CC**              EMIN AND EMAX
C
               CALL STRSIZ (MAXNP, X, Y, NINT, N, COOR(1,IP2),
     &            COOR(2,IP2), XDIFF, YDIFF, D, ERR, TEST, XNOLD, YNOLD,
     &            NXKOLD, LINKEG, LISTEG, BMESUR, MLINK, NPNOLD, NPEOLD,
     &            NNXK, REMESH, REXMIN, REXMAX, REYMIN, REYMAX, IDIVIS,
     &            SIZMIN, EMAX, EMIN, GRAPH, DXMAX)
               IF (ERR) GOTO 340
            ELSE
               DEL = D * DFF
               DO 100 I = 2, N - 1
                  PART = DEL/D
                  X (I) = X (I - 1) + PART * XDIFF
                  Y (I) = Y (I - 1) + PART * YDIFF
                  DEL = DEL * FAC
  100          CONTINUE
            ENDIF

C
C  CORNER GENERATION
C
         ELSEIF (KT .EQ. 2)THEN
            XDA = COOR (1, IP3) - COOR (1, IP1)
            YDA = COOR (2, IP3) - COOR (2, IP1)
            XDB = COOR (1, IP2) - COOR (1, IP3)
            YDB = COOR (2, IP2) - COOR (2, IP3)
            DA = SQRT (XDA **2 + YDA **2)
            DB = SQRT (XDB **2 + YDB **2)
            IF ((DA .EQ. 0.).OR. (DB .EQ. 0.))THEN
               WRITE (*, 10010)KNUM
               ERR = .TRUE.
               GOTO 340
            ENDIF
            D = DA + DB
            DEL = D * DFF
            SUM = 0.0
C
C  BREAK N INTO TWO PARTS APPROPRIATELY
C
            DO 110 I = 2, N - 1
               KI = I
               SUM = SUM + DEL
               IF (SUM + 0.5 * DEL .GT. DA)GOTO 120
               DEL = DEL * FAC
  110       CONTINUE
C
C  GENERATE FIRST SIDE OF CORNER
C
  120       CONTINUE
            NA = KI
            DFF = 1.0/DBLE(NA - 1)
            IF (ABS (1.0 - FAC) .GT. 1.0E-6)
     &         DFF =  (FAC - 1.0)/ (FAC ** (NA - 1) - 1.0)
            DEL = DA * DFF
            DO 130 I = 2, NA
               PART = DEL/DA
               X (I) = X (I - 1) + PART * XDA
               Y (I) = Y (I - 1) + PART * YDA
               DEL = DEL * FAC
  130       CONTINUE
C
C  GENERATE SECOND SIDE OF CORNER
C
            NB = N - KI + 1
            DFF = 1.0/DBLE(NB - 1)
            IF (ABS (1.0 - FAC) .GT. 1.0E-6)
     &         DFF =  (FAC - 1.0)/ (FAC ** (NB - 1) - 1.0)
            DEL = DB * DFF
            NAP = NA + 1
            DO 140 I = NAP, N - 1
               PART = DEL/DB
               X (I) = X (I - 1) + PART * XDB
               Y (I) = Y (I - 1) + PART * YDB
               DEL = DEL * FAC
  140       CONTINUE
C
C  CIRCULAR ARC GENERATION
C
         ELSEIF ((KT .EQ. 3).OR. (KT .EQ. 4).OR. (KT .EQ. 6))THEN
C
C  ARC WITH CENTER GIVEN
C  ARC GOES FROM 1ST POINT TO 2ND IN *COUNTER-CLOCKWISE* DIRECTION.
C
            IF (KT .EQ. 3)THEN
               XCEN = COOR (1, IABS (IP3))
               YCEN = COOR (2, IABS (IP3))
C
C  CIRCLE WITH THIRD POINT ON ARC.
C
            ELSEIF (KT .EQ. 4)THEN
               THETA1 = ATAN2 (COOR (2, IP3) - COOR (2, IP1),
     &            COOR (1, IP3) - COOR (1, IP1)) + PI/2.0
               THETA2 = ATAN2 (COOR (2, IP3) - COOR (2, IP2),
     &            COOR (1, IP3) - COOR (1, IP2)) + PI/2.0
               DET =  - COS (THETA1) * SIN (THETA2) + COS (THETA2) *
     &            SIN (THETA1)
               X1 = 0.5 * (COOR (1, IP1) + COOR (1, IP3))
               Y1 = 0.5 * (COOR (2, IP1) + COOR (2, IP3))
               X2 = 0.5 * (COOR (1, IP2) + COOR (1, IP3))
               Y2 = 0.5 * (COOR (2, IP2) + COOR (2, IP3))
               R =  ( - SIN (THETA2) * (X2 - X1) + COS (THETA2) *
     &            (Y2 - Y1))/DET
               XCEN = X1 + R * COS (THETA1)
               YCEN = Y1 + R * SIN (THETA1)
C
C     CIRCLE WITH RADIUS GIVEN
C
            ELSEIF (KT .EQ. 6)THEN
               DX = 0.5 * (COOR (1, IP2) - COOR (1, IP1))
               DY = 0.5 * (COOR (2, IP2) - COOR (2, IP1))
               CHORD = SQRT (DX * DX + DY * DY)
               R = ABS (COOR (1, IABS (IP3)))
               IF (R .LE. CHORD)THEN
                  XCEN = 0.5 * (COOR (1, IP1) + COOR (1, IP2))
                  YCEN = 0.5 * (COOR (2, IP1) + COOR (2, IP2))
               ELSE
                  ARM = SQRT (R * R - CHORD * CHORD)
                  IF (IP3 .LT. 0)THEN
                     XCEN = COOR (1, IP1) + DX + ARM * DY/CHORD
                     YCEN = COOR (2, IP1) + DY - ARM * DX/CHORD
                  ELSE
                     XCEN = COOR (1, IP1) + DX - ARM * DY/CHORD
                     YCEN = COOR (2, IP1) + DY + ARM * DX/CHORD
                  ENDIF
               ENDIF
            ENDIF
            R1 = SQRT ((COOR (1, IP1) - XCEN) **2 + (COOR (2, IP1) -
     &         YCEN) **2)
            R2 = SQRT ((COOR (1, IP2) - XCEN) **2 + (COOR (2, IP2) -
     &         YCEN) **2)
            IF ((R1 .EQ. 0.).OR. (R2 .EQ. 0.))THEN
               WRITE (*, 10020)KNUM
               ERR = .TRUE.
               GOTO 340
            ENDIF
            THETA1 = ATAN2 (COOR (2, IP1) - YCEN, COOR (1, IP1) - XCEN)
            THETA2 = ATAN2 (COOR (2, IP2) - YCEN, COOR (1, IP2) - XCEN)
C
C  ARC WITH THE CENTER GIVEN
C
            IF (KT .EQ. 3)THEN
               IF ((IP3 .GE. 0).AND. (THETA2 .LE. THETA1))
     &            THETA2 = THETA2 + TWOPI
               IF ((IP3 .LT. 0).AND. (THETA1 .LE. THETA2))
     &            THETA1 = THETA1 + TWOPI
               TANG = THETA2 - THETA1
C
C  CIRCULAR ARC WITH 3RD POINT ON ARC - CLOCKWISE OR COUNTER-CLOCKWISE
C
            ELSEIF (KT .EQ. 4)THEN
               THETA3 = ATAN2 (COOR (2, IP3) - YCEN, COOR (1, IP3) -
     &            XCEN)
               IF (THETA2 .LE. THETA1)THETA2 = THETA2 + TWOPI
               IF (THETA3 .LE. THETA1)THETA3 = THETA3 + TWOPI
               TANG = THETA2 - THETA1
               IF (THETA3 .GT. THETA2)TANG = - (TWOPI - TANG)
C
C     CIRRCULAR ARC WITH RADIUS GIVEN - CLOCKWISE OR COUNTER-CLOCKWISE
C
            ELSEIF (KT .EQ. 6)THEN
               IF ((IP3 .GE. 0).AND. (THETA2 .LE. THETA1))
     &            THETA2 = THETA2 + TWOPI
               IF ((IP3 .LT. 0).AND. (THETA1 .LE. THETA2))
     &            THETA1 = THETA1 + TWOPI
               TANG = THETA2 - THETA1
            ENDIF
C
C  GENERATE THE CIRCLE
C
            ANG = THETA1
            DEL = TANG * DFF
            AA =  (LOG (R2/R1))/ (THETA2 - THETA1)
            BB = R2/EXP (AA * THETA2)
            IF (REMESH) THEN
CC* MODIFIED BY: TED BLACKER
CC* MODIFICATION DATE: 7/31/90
CC* MODIFICATION: ADDED ARGUMENTS TO CALL TO CRCSIZ TO PASS MINIMUM
CC**              ELEMENT SIZE (SIZMIN) AND GETSIZ PARAMETERS OF
CC**              EMIN AND EMAX
C
               CALL CRCSIZ (MAXNP, X, Y, NINT, N, COOR(1,IP2),
     &            COOR(2,IP2), XCEN, YCEN, THETA1, THETA2, TANG, AA, BB,
     &            ERR, TEST, XNOLD, YNOLD, NXKOLD, LINKEG, LISTEG,
     &            BMESUR, MLINK, NPNOLD, NPEOLD, NNXK, REMESH, REXMIN,
     &            REXMAX, REYMIN, REYMAX, IDIVIS, SIZMIN, EMAX, EMIN,
     &            GRAPH, DXMAX)
               IF (ERR) GOTO 340
            ELSE
               DO 150 I = 2, N - 1
                  ANG = ANG + DEL
                  RADIUS = BB * EXP (AA * ANG)
                  X (I) = XCEN + COS (ANG) * RADIUS
                  Y (I) = YCEN + SIN (ANG) * RADIUS
                  DEL = DEL * FAC
  150          CONTINUE
            ENDIF
C
C     ELIPSE
C
         ELSEIF (KT .EQ. 7)THEN
C
C  GET THE ELIPSE PARAMETERS
C
            CALL ELPSPR (MP, KT, KNUM, COOR, LINKP, IP1, IP2,
     &         IABS(IP3), IP3, XCEN, YCEN, THETA1, THETA2, TANG, ICCW,
     &         ICW, AVALUE, BVALUE, ERR)
            IF (ERR) GOTO 340
C
C  GENERATE THE ELIPSE
C
            ANG = THETA1
            DEL = TANG * DFF
            DO 160 I = 2, N - 1
               ANG = ANG + DEL
               RADIUS = SQRT ( (AVALUE **2 * BVALUE **2) /
     &            ( (BVALUE **2 * COS (ANG) **2) +
     &            (AVALUE **2 * SIN (ANG) **2) ) )
               X (I) = XCEN + COS (ANG) * RADIUS
               Y (I) = YCEN + SIN (ANG) * RADIUS
               DEL = DEL * FAC
  160       CONTINUE
C
C     PARABOLA
C
         ELSEIF (KT .EQ. 5)THEN
            IF (N .GT. 250)THEN
               WRITE (*, 10030)KNUM
               ERR = .TRUE.
               GOTO 340
            ENDIF
C
C  CHECK LEGITIMACY OF DATA
C
            XMID =  (COOR (1, IP1) + COOR (1, IP2)) * 0.5
            YMID =  (COOR (2, IP1) + COOR (2, IP2)) * 0.5
            DOT =  (COOR (1, IP2) - COOR (1, IP1)) * (COOR (1, IP3) -
     &         XMID) + (COOR (2, IP2) - COOR (2, IP1)) *
     &         (COOR (2, IP3) - YMID)
            PERP = SQRT ((COOR (1, IP2) - COOR (1, IP1)) **2 +
     &         (COOR (2, IP2) - COOR (2, IP1)) **2) *
     &         SQRT ((COOR (1, IP3) - XMID) **2 + (COOR (2, IP3)
     &         - YMID) **2)
            IF (DOT .GE. 0.05 * PERP)THEN
               WRITE (*, 10040)KNUM
               ERR = .TRUE.
               GOTO 340
            ENDIF
C
C  GET ARC LENGTH
C

            HALFW = SQRT ((COOR (1, IP2) - COOR (1, IP1)) **2 +
     &         (COOR (2, IP2) - COOR (2, IP1)) **2) * 0.5
            IF (HALFW .EQ. 0.)THEN
               WRITE (*, 10010)KNUM
               ERR = .TRUE.
               GOTO 340
            ENDIF
            HEIGHT = SQRT ((XMID - COOR (1, IP3)) **2 +
     &         (YMID - COOR (2, IP3)) **2)
            COEF = HEIGHT/HALFW **2
            TCOEF = 2.0 * COEF
C
C  PARC IS A STATEMENT FUNCTION
C
            PLEFT = PARC ( - TCOEF * HALFW, TCOEF)
            ARCTOT = 2.0 * PARC (TCOEF * HALFW, TCOEF)
            ARCDEL = DFF * ARCTOT
            ARCNXT = ARCDEL
            ARCNOW = 0.0
            THETA = ATAN2 (COOR (2, IP2) - COOR (2, IP1),
     &         COOR (1, IP2) - COOR (1, IP1))
C
C  CORRECT FOR ORIENTATION
C
            CROSS =  (COOR (1, IP3) - XMID) * (COOR (2, IP2) -
     &         COOR (2, IP1)) - (COOR (2, IP3) - YMID) *
     &         (COOR (1, IP2) - COOR (1, IP1))
            IF (CROSS .LT. 0.0)THETA = THETA + PI
            SINT = SIN (THETA)
            COST = COS (THETA)
C
C  FIND POINTS APPROXIMATELY BY INTEGRATION
C
            XL =  - HALFW
            FL = SQRT (1.0 + (TCOEF * XL) **2)
            KOUNT = 1
            DELX = 2.0 * HALFW/200.0
            DO 170 I = 1, 100
               FM = SQRT (1.0 + (TCOEF * (XL + DELX)) **2)
               XR =  - HALFW + DBLE(I) * 2.0 * DELX
               FR = SQRT (1.0 + (TCOEF * XR) **2)
               ARCOLD = ARCNOW
               ARCNOW = ARCNOW + DELX * (FL + 4.0 * FM + FR)/3.0
               IF (ARCNOW .GE. ARCNXT)THEN
C
C  COMPUTE POSITION IN LOCAL COORDINATE SYSTEM
C
                  FRAC =  (ARCNXT - ARCOLD)/ (ARCNOW - ARCOLD)
                  XK = XL + FRAC * 2.0 * DELX
                  YK = COEF * XK **2
C
C  CORRECT FOR ORIENTATION PROBLEM
C
                  IF (CROSS .LT. 0.0)XK =  - XK
C
C  ROTATE IN LINE WITH GLOBAL COORDINATE SYSTEM
C
                  ROTX = XK * COST - YK * SINT
                  ROTY = YK * COST + XK * SINT
C
C  RESTORE XK
C
                  IF (CROSS .LT. 0.0)XK =  - XK
C
C  TRANSLATE
C
                  KOUNT = KOUNT + 1
                  X (KOUNT) = ROTX + COOR (1, IP3)
                  Y (KOUNT) = ROTY + COOR (2, IP3)
C
C  PREPARE FOR NEXT POINT
C
                  IF (KOUNT .GE. N - 1)GOTO 180
                  ARCDEL = ARCDEL * FAC
                  ARCNXT = ARCNXT + ARCDEL
C
C  RESTART INTEGRATION
C
                  XR = XK
                  FR = SQRT (1.0 + (TCOEF * XR) **2)
C
C  CORRECT FOR INTEGRATION ERROR
C
                  ARCNOW = PARC (TCOEF * XR, TCOEF) - PLEFT
               ENDIF
               XL = XR
               FL = FR
  170       CONTINUE
  180       CONTINUE
         ENDIF
C
C  SEE IF THE 1 INTERVAL LINE HAS SOME LENGTH TO IT
C
      ELSE
         IF ((COOR (1, IP1) .EQ. COOR (1, IP2)) .AND. (COOR (2, IP1)
     &      .EQ. COOR (2, IP2)))THEN
            WRITE (*, 10010)KNUM
            ERR = .TRUE.
            GOTO 340
         ENDIF
      ENDIF
C
C     NORMAL EXIT
C     DEFINE LAST POINT EXACTLY
C
      X (N) = COOR (1, IP2)
      Y (N) = COOR (2, IP2)
      IF (TEST) GOTO 340
C
C  DEFINE UNIQUE  (IN THE WHOLE BODY) NODE NUMBERS
C
      LPART = 1000000000 + KNUM * 100000
      DO 190 I = 1, N
         NID (I) = LPART + I
  190 CONTINUE
      NID (1) = IPOINT (IP1)
      NID (N) = IPOINT (IP2)
C
C  FLAG PREVIOUSLY USED POINTS WITH NEGATIVES
C
      IF (NINT .LT. 0)THEN
         DO 200 I = 1, N
            NID (I) =  - NID (I)
  200    CONTINUE
      ENDIF
      IF (IPOINT (IP1) .LT. 0)NID (1) =  - IABS (NID (1))
      IF (IPOINT (IP2) .LT. 0)NID (N) =  - IABS (NID (N))
      IF (IP1 .EQ. IP2)NID (N) =  - IABS (NID (N))
C
C  WRITE OUT NODAL BOUNDARY CONDITIONS FOR THE FIRST POINT
C  IF THE POINT HAS NOT BEEN USED BEFORE
C
      IF (IPOINT (IP1) .GT. 0)THEN
         IF (IPBC1 .GT. 0)THEN
            CALL LTSORT (MP, LINKPB, IPBC1, K, ADDLNK)
            IFLAG = IPBC1
  210       CONTINUE
            DO 220 I = IFPB (K), NPPF (K) + IFPB (K) - 1
               CALL LTSORT (MP, LINKP, LISTPB (1, I), IPNTR1, ADDLNK)
               IF (IPNTR1 .EQ. IP1)THEN
                  KNBC = KNBC + 2
                  IF (KNBC .LE. MAXNBC) THEN
                     IF (REAL) THEN
                        LSTNBC (KNBC - 1) = - IFLAG
                        LSTNBC (KNBC) = IABS (NID (1))
                     ENDIF
                  ELSE
                     NOROOM = .TRUE.
                  ENDIF
                  IF (LISTPB (2, I) .GT. 0)THEN
                     CALL LTSORT (MP, LINKPB, LISTPB (2, I), K, ADDLNK)
                     IFLAG = LISTPB (2, I)
                     GOTO 210
                  ELSE
                     GOTO 230
                  ENDIF
               ENDIF
  220       CONTINUE
            WRITE (*, 10060)IFLAG
            ERR = .TRUE.
            GOTO 340
         ENDIF
  230    CONTINUE
      ENDIF
C
C  WRITE OUT NODAL BOUNDARY CONDITIONS FOR THE SECOND POINT
C  IF THE POINT HAS NOT BEEN USED BEFORE
C
      IF (IPOINT (IP2) .GT. 0)THEN
         IF (IPBC2 .GT. 0)THEN
            CALL LTSORT (MP, LINKPB, IPBC2, K, ADDLNK)
            IFLAG = IPBC2
  240       CONTINUE
            DO 250 I = IFPB (K), NPPF (K) + IFPB (K) - 1
               CALL LTSORT (MP, LINKP, LISTPB (1, I), IPNTR1, ADDLNK)
               IF (IPNTR1 .EQ. IP2)THEN
                  KNBC = KNBC + 2
                  IF (KNBC .LE. MAXNBC) THEN
                     IF (REAL) THEN
                        LSTNBC (KNBC - 1) = - IFLAG
                        LSTNBC (KNBC) = IABS (NID (N))
                     ENDIF
                  ELSE
                     NOROOM = .TRUE.
                  ENDIF
                  IF (LISTPB (2, I) .GT. 0)THEN
                     CALL LTSORT (MP, LINKPB, LISTPB (2, I), K, ADDLNK)
                     IFLAG = LISTPB (2, I)
                     GOTO 240
                  ELSE
                     GOTO 260
                  ENDIF
               ENDIF
  250       CONTINUE
            WRITE (*, 10060)IFLAG
            ERR = .TRUE.
            GOTO 340
         ENDIF
  260    CONTINUE
      ENDIF
C
C  WRITE OUT NODAL BOUNDARY CONDITIONS FOR THE LINE
C  IF THE LINE HAS NOT BEEN USED BEFORE
C
      IF (NINT .GT. 0)THEN
         IF (ILBC .GT. 0)THEN
            CALL LTSORT (ML, LINKLB, ILBC, K, ADDLNK)
            IFLAG = ILBC
  270       CONTINUE
            DO 290 I = IFLB (K), NLPF (K) + IFLB (K) - 1
               IF (LISTLB (1, I) .LE. 0)THEN
                  CALL MESAGE ('PROBLEMS WITH SIDES IN FLAG LIST'//
     &               ' IN PLINE')
               ELSE
                  IF (LISTLB (1, I) .EQ. KNUM)THEN
                     KNBC = KNBC + 1
                     IF (KNBC .LE. MAXNBC) THEN
                        IF (REAL) LSTNBC (KNBC) = - IFLAG
                     ELSE
                        NOROOM = .TRUE.
                     ENDIF
                     DO 280 J = 1, N
                        KNBC = KNBC + 1
                        IF (KNBC .LE. MAXNBC) THEN
                           IF (REAL) LSTNBC (KNBC) = IABS (NID (J))
                        ELSE
                           NOROOM = .TRUE.
                        ENDIF
  280                CONTINUE
                     IF (LISTLB (2, I) .GT. 0)THEN
                        CALL LTSORT (ML, LINKLB, LISTLB (2, I), K,
     &                     ADDLNK)
                        IFLAG = LISTLB (2, I)
                        GOTO 270
                     ELSE
                        GOTO 300
                     ENDIF
                  ENDIF
               ENDIF
  290       CONTINUE
            WRITE (*, 10050)IFLAG
            ERR = .TRUE.
            GOTO 340
         ENDIF
  300    CONTINUE
      ENDIF
C
C  IF COUNT, THEN COUNT THE SIDE BOUNDARY CONDITIONS FOR THE LINE
C  NOTE: IT DOES NOT MATTER IF THE LINE HAS BEEN USED BEFORE
C
      IF ((COUNT) .AND. (ISBC .GT. 0))THEN
         CALL LTSORT (ML, LINKSB, ISBC, K, ADDLNK)
         IFLAG = ISBC
  310    CONTINUE
         DO 320 I = IFSB (K), NSPF (K) + IFSB (K) - 1
            IF (LISTSB (1, I) .LT. 0)THEN
               CALL MESAGE ('PROBLEMS WITH SIDES IN FLAG LIST IN PLINE')
            ELSE
               IF (LISTSB (1, I) .EQ. KNUM)THEN
                  KSBC = KSBC + ((N - 1) * 3)
                  IF (KSBC .GT. MAXSBC) NOROOM = .TRUE.
                  IF (LISTSB (2, I) .GT. 0)THEN
                     CALL LTSORT (ML, LINKSB, LISTSB (2, I), K, ADDLNK)
                     IFLAG = LISTSB (2, I)
                     GOTO 310
                  ELSE
                     GOTO 330
                  ENDIF
               ENDIF
            ENDIF
  320    CONTINUE
         WRITE (*, 10070)IFLAG
         ERR = .TRUE.
         GOTO 340
      ENDIF
  330 CONTINUE
C
C  NORMAL COMPLETION
C
  340 CONTINUE
C
      RETURN
C
10000 FORMAT (' ZERO NUMBER OF INTERVALS FOR LINE', I5)
10010 FORMAT (' ZERO LINE LENGTH ENCOUNTERED FOR LINE', I5)
10020 FORMAT (' POINTS GIVEN FOR LINE', I5, ' DO NOT DEFINE AN ARC')
10030 FORMAT (' MORE THAN 250 POINTS FOR PARABOLA NOT ALLOWED - LINE',
     &   I5)
10040 FORMAT (' POINTS GIVEN FOR LINE', I5, ' DO NOT DEFINE A PARABOLA')
10050 FORMAT (' LINE BOUNDARY FLAG', I5, ' IS NOT PROPERLY LINKED')
10060 FORMAT (' POINT BOUNDARY FLAG', I5, ' IS NOT PROPERLY LINKED')
10070 FORMAT (' SIDE BOUNDARY FLAG', I5, ' IS NOT PROPERLY LINKED')
C
      END

max_stars_repo_name: smukher/seacas

max_issues_repo_name: smukher/seacas

max_forks_repo_name: smukher/seacas


text:
	SUBROUTINE GPINP  ( device, map, garea, proj, satfil, radfil,
     +			     panel, title, text, latlon, clear,
     +                       asfil, ashr, asatt, lutfil, imcbar, iret )
C************************************************************************
C* GPINP								*
C*									*
C* This subroutine gets the input for GPWATCH.				*
C*									*
C* GPINP  ( DEVICE, MAP, GAREA, PROJ, SATFIL, RADFIL, PANEL, TITLE,	*
C*	    TEXT, LATLON, CLEAR, SATFIL, RADFIL, ASFIL, ASHR, ASATT, 	*
C*	    LUTFIL, IMCBAR, IRET)					*
C**									*
C* Log:									*
C* Chiz/Unidata	 6/96	Developed from GPMINP				*
C************************************************************************
	CHARACTER*(*)	device, map, garea, proj, panel, title, text,
     +			latlon, satfil, radfil, asfil, ashr, asatt,
     +			lutfil, imcbar
	LOGICAL		clear
C-----------------------------------------------------------------------
	CALL IP_STR  ( 'DEVICE', device, ier1 )
	CALL IP_STR  ( 'MAP',    map,    ier2 )
	CALL IP_STR  ( 'GAREA',  garea,  ier3 )
	CALL IP_STR  ( 'PROJ',   proj,   ier4 )
	CALL IP_STR  ( 'PANEL',  panel,  ier5 )
	CALL IP_STR  ( 'TITLE',  title,  ier6 )
	CALL IP_STR  ( 'TEXT',   text,   ier7 )
	CALL IP_STR  ( 'LATLON', latlon, ier8 )
	CALL IP_LOG  ( 'CLEAR',  clear,  ier9 )
	CALL IP_STR  ( 'SATFIL', satfil, ier10 )
	CALL IP_STR  ( 'RADFIL', radfil, ier11 )
	CALL IP_STR  ( 'ASFIL',  asfil,  ier12 )
	CALL IP_STR  ( 'ASHR',   ashr,   ier13)
	CALL IP_STR  ( 'ASATT',  asatt,  ier14)
	CALL IP_STR  ( 'LUTFIL', lutfil, ier15)
	CALL IP_STR  ( 'IMCBAR', imcbar, ier16)
C
	iret =  ier1 + ier2 + ier3 + ier4 + ier5 + ier6 + ier7 +
     +		ier8 + ier9 + ier10 + ier11 + ier12 + ier13 + ier14 +
     +		ier15 + ier16
	IF  ( iret .ne. 0 )  iret = -2
C*
	RETURN
	END


text:
      SUBROUTINE MA01AD( XR, XI, YR, YI )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the complex square root YR + i*YI of a complex number
C     XR + i*XI  in real arithmetic.  The returned result is so that
C     YR >= 0.0  and  SIGN(YI) = SIGN(XI).
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     XR      (input) DOUBLE PRECISION
C     XI      (input) DOUBLE PRECISION
C             These scalars define the real and imaginary part of the
C             complex number of which the square root is sought.
C
C     YR      (output) DOUBLE PRECISION
C     YI      (output) DOUBLE PRECISION
C             These scalars define the real and imaginary part of the
C             complex square root.
C
C     METHOD
C
C     The complex square root YR + i*YI of the complex number XR + i*XI
C     is computed in real arithmetic, taking care to avoid overflow.
C
C     REFERENCES
C
C     Adapted from EISPACK subroutine CSROOT.
C
C     CONTRIBUTOR
C
C     P. Benner, Universitaet Bremen, Germany, and
C     R. Byers, University of Kansas, Lawrence, USA,
C     Aug. 1998, routine DCROOT.
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Oct. 1998, SLICOT Library version.
C
C     REVISIONS
C
C     -
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, HALF
      PARAMETER         ( ZERO = 0.0D0, HALF = 1.0D0/2.0D0 )
C     ..
C     .. Scalar Arguments ..
      DOUBLE PRECISION  XR, XI, YR, YI
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION  S
C     ..
C     .. External Functions ..
      DOUBLE PRECISION  DLAPY2
      EXTERNAL          DLAPY2
C
C     .. Intrinsic functions ..
      INTRINSIC         ABS, SQRT
C     ..
C     .. Executable Statements ..
C
      S = SQRT( HALF*( DLAPY2( XR, XI ) + ABS( XR ) ) )
      IF ( XR.GE.ZERO ) YR =  S
      IF ( XI.LT.ZERO ) S  = -S
      IF ( XR.LE.ZERO ) THEN
         YI =  S
         IF ( XR.LT.ZERO ) YR =  HALF*( XI/S )
      ELSE
         YI =  HALF*( XI/YR )
      END IF
C
      RETURN
C     *** Last line of MA01AD ***
      END

max_stars_repo_name: bnavigator/SLICOT-Reference

max_issues_repo_name: RJHKnight/slicotr

max_forks_repo_name: RJHKnight/slicotr