text:
c************************************************************************
c
c        subroutine name: dsub
c
c        update history
c        --------------
c        revision a - initial release    1/1/84     bam
c        revision b - 3/19/84   bam
c                     1. added entry point autot for autotracking
c                     2. modified rcurse for autotracking on
c
c        revision c - 5/4/84    bam
c                     1. chnged entry point symbol name to dsymbol
c                     2. added a rounding factor to ddraw and dmove
c
c        revision d - 2/85      ram
c                     1. added ability to choose different cursors
c                     2. added ability to selectively erase graphics
c                        colors
c
c        revision e - 4/85      bam/ram
c                     1. removed all calls to error conditions
c                     2. inserted calls to error subroutine
c                     3. made code flexible for all display devices
c                        with differing types of hardware
c
c        revision f - 9/86      bam
c                     1. added 1024 graphics capability
c                     2. added pan capability
c                     3. added zoom capability
c
c        purpose:
c        this is the interface subroutine between the
c        display device interface routines and the
c        ramtek 'D' routines
c
c
         subroutine dsub

         logical xddactivate, xddconfigure, xddinfo, xddopen
         logical xdlconnect, xdlramp, xdlwrite, xdipolyline
         logical xdidwset, xdifill, xdilineread, xdilinewrite,  xdizoom
         logical xdcautotrack, xdclocation, xdcoff, xdcon, xdcset
         logical xdglwrite, xdtcolor, xdtfont,  xdtrotate, xdgconnect
         logical xdtsize, xdttext, xdx2d, xdimfill, xdgon, xdgoff
c
         real*4 cx, cy
	 integer  ipen, iprox, lines, samples, outmodes
         integer  u, i, p, ilad, isad, nsamps
         integer  h, ilds, isds, no, ivd, gmask, ib
         integer  th, itemp, itemp1
         integer  c, iform, iconoff, iblink, iw
         integer  section, loc, icount, ifont
         integer  ix1, iy1, gplane
         integer  csetup(4), asetup(4), larray(256)
         integer  xarray(2), yarray(2)
         integer  red(256), green(256), blue(256)
         integer  kr,currd3
         integer  ihzoom, irb
c
         integer n, autoflag, prev_auto, ip
         integer dlds, dsds, dzoom
c
         logical flag, cauto, on
         byte buf(*), a(*), v, w
         dimension trans1(9), trans2(9), trans3(9), trans4(9)
c
	 character*80 msg
         character*30 ctbl0(3)/ ' Video Output = 512x512       ',
     -                          ' Video Output = 1024x1024     ',
     -                          ' Video Output = 640x480       '/
         character*30 ctbl7A/' GRAPHICS PLANE AVAILABLE     '/
         character*30 ctbl7B/' GRAPHICS PLANE NOT AVAILABLE '/
         character*30 ctbl7C/' GRAPHICS WILL BE PLACED ON   '/
         character*30 ctbl7D/'       IMAGE PLANE 1          '/
c
         character check(4), gdisid, vdisid
         equivalence ( jdisid, check )
	 byte bcheck(4)
	 equivalence (check, bcheck)
c
c        save all pertinant variables for later entries
c
         integer lmax, smax
         save u, i, c, iform, iblink, iconoff, h, s, v, w,
     -        section, loc, x1, y1, x1c, y1c, no, p, gplane,
     -        red, green, blue, autoflag, lmax, smax

         common/xddev/ nluts, nimps, maxlines, maxsamps, igraph,
     -                 ncurs, nintio
c
c        here are some of the more reasonable dset possibilities
c
         character*2 jkey(7) / 'DW','DH','NW','NH','PO','CO','VL'/
	 character*2 itest
c
c        set up the cursor array for cset here
c
	 character*4 key
         character*4 ikey(7) / 'VISI', 'INVI', 'BLIN', 'NBLI',
     &                     'C1  ', 'C2  ', 'C3  ' /
c
c        initially, set up dapply transformation function to a
c        unit matrix. transformation function 3 will be required
c        to transform ramtek x, y cartesian coordinates to
c        picture coordinates in line/sample mode.
c
         data trans1/1.,0.,0.,0.,1.,0.,0.,0.,1./
         data trans3/0.,511.,0.,-511.,0.,0.,512.,1.,0./
         data trans4/0.,1023.,0.,-1023.,0.,0.,1023.,1.,0./
c
c        turn autotracking flag off
c
         data autoflag / 0 /
c
c        set v to 0 for erase call
c
         data v / 0 /
c
c        set w to white for drawing lines
c
         data w / 1 /
         data red   / 0,255*255 /
         data green / 0,255*255 /
         data blue  / 0,255*255 /
c
c        set the no. of elements in the xarray and yarrays
c        to 2 for the xdipolyline routine
c
         data no / 2 /
c
c        use defualt cursor and default unit
c
         data u / 1 /, c / 1 /
c
c        set up arrays for configuration and allocation
c
         data csetup / 0, 0, 0, 0 /
         data asetup / 1, 1, 0, 0 /
c
c        set location value ( loc ) for dtext
c
         data loc / 1 /
c
c        set default section of lut for xdlwrite
c
         data section / 1 /
c
c        set the default cursor form to 0
c        and the blink rate off
c
         data iform / 0 /, cauto / .true. /
         data iblink / 0 /, iconoff / 0 /
c
c        default pan and zoon factors
c
         data dlds/0/, dsds/0/, dzoom/1/
c
c        set initial xdtsize values
c
         data h / 7 /, s / 1.0 /
c
c        set xdtcolor percision to 0
c
         data p / 0 /
c
c        initialize the graphics origin to the
c        lower l hand corner
c
         data x1c / 0.0 /, y1c / 0.0 /, x1 / 1.0 /, y1 / 512.0 /
c
c        set up data information to check for graphics
c        or video erases
c
         data gdisid / 'G' /, vdisid / 'V' /
c
c---------------------------------------------------------
c
c
c
c        devopen
c         the devopen call is the first call that must be
c         made to the d routines. it will open the required
c         unit, allocate devices, configure them as required,
c         and activate them so that they can be read to and
c         from. the graphics plane is set to 4 and turned on.
c         a font is read in; character height is specified;
c         and text angle rotation is set to 0.
c
c         calling sequence ( iunit )
c         where :
c                iunit - device logical unit no.
c
          entry devopen ( iunit )
          u = iunit
c
c         allocate display unit
c
          ierr = xddallocate ( u, asetup )
          call errors ( ' XDDALLOCATE', ierr )
          if ( ierr .eq. 0 ) then
           call xvmessage(' Display not active or allocated',' ')
           call abend
          end if
c
c         normal return - we were able to allocate the device required
c
c         open unit u
c
          ierr = xddopen ( u )
          call errors ( ' XDDOPEN', ierr )
          if (ierr .ne. 1 ) then
            call qprint( ' Device open failed aborting.....' )
            call abend
          end if
c
c         activate the display unit so that we can write on it
c
          flag = .true.
          ierr = xddactivate ( u, flag )
          call errors ( ' XDDACTIVATE', ierr )
c
c         now configure the display (csetup is all 0's - default)
c
          ierr = xddconfigure ( u, csetup )
          call errors ( ' XDDCONFIGURE', ierr )
c
c         find out what type of device we have
c
          ierr = xddinfo ( u, 3, 1,  nluts )
          ierr = xddinfo ( u, 4, 1,  nimps )
          ierr = xddinfo ( u, 5, 1,  maxlines )
          ierr = xddinfo ( u, 6, 1,  maxsamps )
          ierr = xddinfo ( u, 30, 1, igraph )
          ierr = xddinfo ( u, 34, 1, gplane )
          ierr = xddinfo ( u, 48, 1, ncurs )
          ierr = xddinfo ( u, 60, 1, nintio )
          lmax = maxlines
          smax = maxsamps
c
c         read in a font file
c
          ifont = 1
          ierr  = xdtfont ( ifont )
          call errors ( ' XDTFONT', ierr )
c
c         set the initial size
c
          if ( lmax .le. 512 ) then
            h = 7
          else
            h = 14
          end if

          ierr = xdtsize ( h, s )
          call errors ( ' XDTSIZE', ierr )
c
c         rotate at 0 degrees
c
          angle = 0.0
          ierr  = xdtrotate ( angle )
          call errors ( ' XDTROTATE', ierr )
c
c         turn on the cursor
c
          if ( ncurs .gt. 0 ) then
           iconoff = 1
           ierr = xdcon ( u, c, iform, iblink )
           call errors ( ' XDCON', ierr )
          end if
c
c         and the ramps
c
          do nl = 1, nluts
           ierr = xdlramp ( u, nl, section )
           call errors ( ' XDLRAMP', ierr )
           ierr = xdlconnect ( u, 1, nl, section, .FALSE. )
           call errors ( ' XDLCONNECT', ierr )
          end do
c
c         connect the graphics plane to image plane
c
          if ( igraph .gt. 0 ) then
           ierr   = xdgconnect ( u, gplane, section, .false. )
           call errors ( ' XDGCONNECT', ierr )
c
c          turn on the graphics overlay plane
c
           ierr = xdgon ( u )
           call errors ( ' XDGON', ierr )
c
c          initialize graphics lut
c
           red(2)   = 255	! red
           green(2) = 0
           blue(2)  = 0
           red(3)   = 0		! green
           green(3) = 255
           blue(3)  = 0
           red(5)   = 0		! blue
           green(5) = 0
           blue(5)  = 255
           red(9)   = 255	! white
           green(9) = 255
           blue(9)  = 255
           red(17)   = 0	! black
           green(17) = 0
           blue(17)  = 0
           red(33)   = 255      ! yellow
           green(33) = 255
           blue(33)  = 0
           red(65)   = 0	! cyan
           green(65) = 255
           blue(65)  = 255
           red(129)   = 255	! magenta
           green(129) = 0
           blue(129)  = 255
           ierr = xdglwrite( u, section, red, green, blue )
           call errors ( ' XDGLWRITE', ierr )
          end if
c
          return

c--------------------------------------------------------------------------
c
c	devconf
c		configure the device given a number of
c	lines and samples.  If the lines and samples are 0,
c	the the default configuration for the device is used
c	and the number of lines and samples are set to the
c	appropriate values.  Otherwise the device will be
c	configured to one of the following if it is available:
c		512x512 when lines=512 and samples=512
c		640x480 when lines=480 and samples=640
c		1024x1024 when lines=1024 and samples=1024
c	If the given lines and samples do not match any of
c	the above, the device's default is used but the values
c	of lines and samples are not changed.
c
	entry devconf( lines, samples )
c
      ierr = xddinfo( u, 7, 1, outmodes )
      if ( (lines .eq. 1024) .and. (samples .eq. 1024) ) then
       if ( btest(outmodes,9) ) then
         csetup(2) = 2
         csetup(3) = 2
       else
         call xvmessage(' 1024x1024 Output Not Available ',' ')
       end if

      else if ( (lines .eq. 480) .and. (samples .eq. 640) ) then
       if ( btest(outmodes,10) ) then
         csetup(2) = 2
         csetup(3) = 3
       else
         call xvmessage(' 640x480 Output Mode Not Available ',' ')
       end if

      else if ( (lines .eq. 512) .and. (samples .eq. 512) ) then
       if ( btest(outmodes,8) ) then
         csetup(2) = 1
         csetup(3) = 1
       else
         call xvmessage( ' 512x512 Output Mode Not Available ',' ')
       end if

      else
       csetup(1) = 0
       csetup(2) = 0
       csetup(3) = 0
       csetup(4) = 0
       if ( (lines .ne. 0) .and. (samples.ne.0) ) call xvmessage(
     +     ' Unrecognized Output Size, Display Default Used ',' ')
      end if
c
c         now configure the display
c
          ierr = xddconfigure ( u, csetup )
	  call errors(' XDDCONFIGURE', ierr)
c
c         find out what type of device we have
c
          ierr = xddinfo ( u, 3, 1,  nluts )
          ierr = xddinfo ( u, 4, 1,  nimps )
          ierr = xddinfo ( u, 5, 1,  maxlines )
          ierr = xddinfo ( u, 6, 1,  maxsamps )
          ierr = xddinfo ( u, 12, 1, currd3 )
          ierr = xddinfo ( u, 30, 1, igraph )
          ierr = xddinfo ( u, 34, 1, gplane )
          ierr = xddinfo ( u, 48, 1, ncurs )
          ierr = xddinfo ( u, 60, 1, nintio )
c
c         print out what we have
c
	  call xvmessage(' ',' ')
          call xvmessage(' Display Device Characteristics',' ')
	  call xvmessage(' ',' ')
	  call xvmessage(ctbl0(currd3),' ')
	  write (msg,110) nluts
  110	  format(' No. of LUTs =',i6)
	  call xvmessage(msg,' ')
	  write (msg,120) nimps
  120	  format(' No. of IMPs =',i6)
	  call xvmessage(msg,' ')
	  write (msg,130) maxlines
  130	  format(' No. of LINES =',i5)
	  call xvmessage(msg,' ')
	  write (msg,140) maxsamps
  140	  format(' No. of SAMPS =',i5)
	  call xvmessage(msg,' ')
	  write (msg,150) ncurs
  150	  format(' No. of CURSORS =',i3)
	  call xvmessage(msg,' ')
	  write (msg,160) nintio
  160	  format(' No. of IO DEVS =',i3)
	  call xvmessage(msg,' ')

          if ( igraph .eq. 1 ) then
           call xvmessage(ctbl7a,' ')
          else
           call xvmessage(ctbl7b,' ')
           call xvmessage(' ',' ')
           call xvmessage(ctbl7c,' ')
           call xvmessage(ctbl7d,' ')
           gplane = 1
          end if
          call xvmessage(' ',' ')

	if ( (lines.eq.0).and. (samples.eq.0) ) then
	 lines = maxlines
	 samples = maxsamps
	end if
c
c         connect the graphics plane to image plane
c
          if ( igraph .gt. 0 ) then
           ierr   = xdgconnect ( u, gplane, section, .false. )
	   call errors(' xdgconnect', ierr)
c
c          initialize graphics lut
c
           ierr = xdglwrite( u, section, red, green, blue )
	   call errors(' xdglwrite', ierr)
          end if

        lmax = lines
        smax = samples

        if ( lmax .le. 512 ) then
           h = 7
        else
           h = 14
        end if

        ierr = xdtsize ( h, s )
	call errors(' xdtsize',ierr)

	return
c
c-----------------------------------------------------------------
c
c
c        devclose
c         to deactivate the ability to modify the display unit u
c         and to deallocate it for the next user
c
c
         entry devclose
c
c        deactivate the device
c
         flag = .false.
         ierr = xddactivate ( u, flag )
	 call errors(' XDDACTIVATE', ierr)
c
c        now close unit
c
         ierr = xddfree ( u )
	 call errors(' XDDFREE', ierr)
c
         return
c
c
c----------------------------------------------------------------
c
c        dcolor
c         this is routine that connects the image planes
c         to the color luts. for full color, image planes
c         1,2, and 3 are connected to the associasted luts
c         and the graphics plane is connected to image
c         plane 4.
c
c
         entry dcolor(ind)
c
          if ( (nimps .ge. 3) .and. (nluts .eq. 3) ) then
           icolor = 0
           ierr  = xdlconnect ( u, 1, 1, 1, .false. )
	   call errors(' xdlconnect', ierr)
           ierr  = xdlconnect ( u, 2, 2, 1, .false. )
	   call errors(' xdlconnect', ierr)
           ierr  = xdlconnect ( u, 3, 3, 1, .false. )
	   call errors(' xdlconnect', ierr)
           ind = 1
          else
           call xvmessage(' COLOR mode not available for this device',
     &			  ' ')
           ind = 0
          end if
         return
c
c----------------------------------------------------------------
c
c        dpscolor
c         this is routine that connects the image planes
c         to the color luts. for pseudo color, image planes
c         1,2, and 3 are connected to lut 1.
c
c
c
         entry dpscolor(ind)
c
          if ( nluts .eq. 3 ) then
           icolor = 1
           ierr = xdlconnect ( u, 1, 1, 1, .false. )
	   call errors(' xdlconnect', ierr)
           ierr = xdlconnect ( u, 1, 2, 1, .false. )
	   call errors(' xdlconnect', ierr)
           ierr = xdlconnect ( u, 1, 3, 1, .false. )
	   call errors(' xdlconnect', ierr)
           ind = 1
          else
	   call xvmessage(' Pseudocolor not available for this device',
     +			  ' ')
           ind = 0
          end if
         return
c
c----------------------------------------------------------------
c
c
c        bw
c         this is the routine that connects image 1 to lut 1
c         2, and 3 and turns on the linear ramps.
c
          entry bw
c
          do nl = 1, nluts
           icolor = 0
           ierr = xdlconnect ( u, 1, nl, 1, .false. )
	   call errors(' xdlconnect', ierr)
c
c          and the ramp
c
           ierr = xdlramp ( u, nl, section )
	   call errors(' xdlramp', ierr)
          end do
         return
c----------------------------------------------------------------
c
c
c        autot
c         this is the routine that turns autotracking on
c
          entry autot( on )
c
          if ( nintio .gt. 0 ) then
           if ( on ) then
            autoflag = 1
           else
            autoflag = 0
           end if
           ierr = xdcautotrack ( u, c, 0, autoflag )
	   call errors(' xdcautotrack', ierr)
          end if
          return
c
c----------------------------------------------------------------
c
c        gon
c         this is a routine to turn on the graphics overlay plane
c
c
          entry gon
c
c         turn on the graphics overlay plane
c
          if ( igraph .gt. 0 ) then
           ierr = xdgon ( u )
	   call errors(' xdgon', ierr)
          else
           call xvmessage(ctbl7b,' ')
          end if
          return
c
c----------------------------------------------------------------
c
c        goff
c         this is a routine to turn off the graphics overlay plane
c
c
          entry goff
c
c         turn off the graphics overlay plane
c
          if ( igraph .gt. 0 ) then
           ierr = xdgoff ( u )
	   call errors(' xdgoff', ierr)
          else
           call xvmessage(ctbl7b,' ')
          end if
          return
c
c----------------------------------------------------------------
c
c        dopen
c         this is basically a dummy routine now
c
c         calling sequence ( ind, idisid )
c         where :
c                ind    - is the returned error code
c                idisid - device logical unit no.
c
          entry dopen ( ind, idisid )
c
c         successful open
c
          ind = 0
          return
c
c-----------------------------------------------------------------
c
c
c        dclose
c         also a dummy routine
c
c
          entry dclose ( ind, idisid )
c
c         successful close
c
          ind = 0
          return
c
c----------------------------------------------------------------
c
c
c        dcheck
c         this is a dummy routine where the return code is
c         set to 0
c
c
         entry dcheck ( ind, idisid )
c
         ind = 0
         return
c
c-----------------------------------------------------------------
c
c
c       dini
c       the dini call will be used to get the logical
c       device name for the variable i which is
c       required for the interface graphics routines
c
        entry dini ( idisid )
c
        jdisid = idisid
        i = gplane
c
c       set up w as required
c
        w = iv ( bcheck(2) ) - 48
c
        return
c
c-----------------------------------------------------------------
c
c
c       dapply
c        the original purpose of this routine was to
c        transform picture coordinates to graphics plane
c        coordinates in the range of 0 to 1
c
c        calling sequence: ( matrix )
c        where: matrix - the required transformation matrix
c                        of length 9
c
c
        entry dapply ( trans2 )
         call mve (7,9,trans2,trans1,1,1)
        return
c
c------------------------------------------------------------------
c
c
c       dmove
c        dmove will move the current operating point ( cop )
c        to a new location without drawing a line
c
c        calling sequence: ( x, y )
c         where  x - the x coordinate of the new cop
c                y - the y coordinate of the new cop
c
c
         entry dmove ( x, y )
c
         x1c = x * trans1(1) + y * trans1(4) + trans1(7)
         y1c = x * trans1(2) + y * trans1(5) + trans1(8)
         go to 10
c
c------------------------------------------------------------------
c
c
c       drmove
c        drmove will move the current operating point ( cop )
c        to a new location relative to where it is currently
c        positioned without drawing a line.
c
c        calling sequence: ( dx, dy )
c         where  dx - the x coordinate to be added to the
c                     current location in order to update
c                     the cop
c                dy - the y coordinate to be added to the
c                     current location in order to update
c                     the cop
c
c
         entry drmove ( dx, dy )
c
         x1c = x1c + dx * trans1(1) + dy * trans1(4)
         y1c = y1c + dx * trans1(2) + dy * trans1(5)
c
c        now to sample (x) and line (y) coordinates
c
 10      continue

         if ( lmax .le. 512 ) then
             x1 = x1c * trans3(2) + trans3(8) + 0.5
             y1 = y1c * trans3(4) + trans3(7) + 0.5
         else
             x1 = x1c * trans4(2) + trans4(8) + 0.5
             y1 = y1c * trans4(4) + trans4(7) + 0.5
         end if
         return
c
c------------------------------------------------------------------
c
c
c       ddraw
c        ddraw will draw a line from the cop to a new point ( np ).
c        after the line is drawn, the cop will be updated to the
c        np.
c
c        calling sequence: ( x, y )
c         where  x - the x coordinate of the terminus of the line
c                y - the y coordinate of the terminus of the line
c
c
         entry ddraw ( x, y )
c
         x2c = x * trans1(1) + y * trans1(4) + trans1(7)
         y2c = x * trans1(2) + y * trans1(5) + trans1(8)
         go to 20
c
c------------------------------------------------------------------
c
c
c
c       drdraw
c        drdraw will draw a vector to a new point ( np )
c        whose terminus is computed by x2 = x1 + dx
c        and y2 = y1 + dy. after the draw is completed,
c        the cop will be updated to ( x2, y2 ).
c
c        calling sequence: ( dx, dy )
c         where  dx - the x coordinate to be added to the
c                     current location
c                dy - the y coordinate to be added to the
c                     current location
c
c
         entry drdraw ( dx, dy )
c
         x2c = x1c + dx * trans1(1) + dy * trans1(4)
         y2c = y1c + dx * trans1(2) + dy * trans1(5)
c
c        now to sample (x) and line (y) coordinates
c
 20      continue
         if ( lmax .le. 512 ) then
             x2 = x2c * trans3(2) + trans3(8) + 0.5
             y2 = y2c * trans3(4) + trans3(7) + 0.5
         else
             x2 = x2c * trans4(2) + trans4(8) + 0.5
             y2 = y2c * trans4(4) + trans4(7) + 0.5
         end if
c
         xarray(1) = x1
         xarray(2) = x2
         yarray(1) = y1
         yarray(2) = y2
c
         if ( w .eq. 0 ) then
          gmask = 0
         else
          gmask = w
          gmask = 2**(gmask-1)
         end if
         if ( igraph .eq. 0 ) gmask = 255
         ierr = xdipolyline ( u, i, gmask, no, xarray, yarray )
	 call errors(' xdipolyline', ierr)
c
c        update the cop
c
         x1  = x2
         y1  = y2
         x1c = x2c
         y1c = y2c
         return
c
c------------------------------------------------------------------
c
c
c       dtext
c        dtext will write out a line of text to an image
c        memory plane
c
c        calling sequence: ( a, jcount )
c         where: a      - byte array containing text
c                jcount - no. of characters in array a
c
c
        entry dtext ( a, jcount )
c
        icount = jcount
c
c       set the 'complimentary or positive' mode on
c
        if ( w .eq. 0 ) then
         iw = 0
        else
         iw = w
         iw = 2**(iw-1)
        end if
        if ( igraph .eq. 0 ) iw = 255
        ierr = xdtcolor ( iw, p )
	call errors(' xdtcolor',ierr)
c
c       now write the text string
c
        ix1    = x1
        iy1    = y1
        ierr   = xdttext ( u, i, ix1, iy1, loc, icount, a )
	call errors(' xdttext', ierr)
c
        return
c
c------------------------------------------------------------------
c
c
c        dsymbol
c         dsymbol will write out a line of text to the graphics plane
c         at a user speciied height and angle
c
c        calling sequence ( tx, ty, tsize, a, tangle, nchar )
c        where:
c              tx     - x position of the text string
c              ty     - y position of the text string
c              tsize  - user specified height of the text
c              texbuf - buffer containing the text
c              tangle - angle to print the text
c              nchar  - no. of characters to print
c
         entry dsymbol ( tx, ty, tsize, a, tangle, nchar )
c
c
c         find where to put the text
c
          xtc = tx * trans1(1) + ty * trans1(4) + trans1(7)
          ytc = tx * trans1(2) + ty * trans1(5) + trans1(8)
          if ( lmax .le. 512 ) then
              xt  = xtc * trans3(2) + trans3(8)
              yt  = ytc * trans3(4) + trans3(7)
          else
              xt  = xtc * trans4(2) + trans4(8)
              yt  = ytc * trans4(4) + trans4(7)
          end if
          ts    = 1.0
c
          if ( tsize .lt. 1.0 ) then
           tsize = tsize * 511.0
          end if
c
          th = tsize
c
          ierr  = xdtsize ( th, ts )
	  call errors(' xdtsize', ierr)
c
c         rotate to user specified angle
c
          if ( tangle .gt. 180.0 ) then
           tangle = tangle - 360.0
          else if ( tangle .lt. -180.0 ) then
           tangle = tangle + 360.0
          end if
c
          ierr  = xdtrotate ( tangle )
	  call errors(' xdtrotate', ierr)
c
c       set the 'complimentary or positive' mode on
c
        icount = nchar
        if ( w .eq. 0 ) then
         iw = 0
        else
         iw = w
         iw = 2**(iw-1)
        end if
        if ( igraph .eq. 0 ) iw = 255
        ierr   = xdtcolor ( iw, p )
	call errors(' xdtcolor', ierr)
c
c       now write the text string
c
        ix1    = xt
        iy1    = yt
        ierr   = xdttext ( u, i, ix1, iy1, loc, icount, a )
	call errors(' xdttext', ierr)
c
c       rotate back to 0 degrees
c
        angle = 0.0
        ierr  = xdtrotate ( angle )
	call errors(' xdtrotate', ierr)
c
c       and reset the character size
c
        ierr = xdtsize ( h, s )
	call errors(' xdtsize', ierr)
        return
c
c------------------------------------------------------------------
c
c
c        vline/rline
c         vline will write from 1 to n lines of information
c         to a video device while rline will read information
c         from the video device.
c
c        calling sequence ( idisid, buf, islds, issds, nlds, nsds )
c        where:
c              idisid - video device logical unit no.
c              buf    - buffer for transfer of information
c              islds  - starting line coordinate
c              issds  - starting sample coordinate
c              nlds   - no. of lines to be written
c              nsds   - no. of samples per line
c
         entry vline ( idisid, buf, islds, issds, nlds, nsds )
c
c        set up start line and sample addresses
c
         isad = issds
         ilad = islds
c
c        nsamps is the no. of samples to display / line
c        ensure nsamps is even so that xdilinewrite will work
c        correctly.
c
         if ( (isad-1) + nsds .gt. maxsamps ) then
          nsamps = maxsamps - isad - 1
         else
          nsamps = nsds
         end if
         nsamps = (( nsamps + 1 ) / 2 ) * 2
c
c        extract the display device no.
c
         jdisid = idisid
         ivd    = iv ( bcheck(2) ) - 48
c
c        write pixels
c
         n    = nlds
         do j = 1, n
          ierr  = xdilinewrite ( u, ivd, isad, ilad, nsamps, buf )
	  call errors(' xdilinewrite', ierr)
          ilad = ilad + 1
         end do
         return
c
c
c
         entry rline ( idisid, buf, islds, issds, nlds, nsds )
c
c        set up start line and sample addresses
c
         isad = issds
         ilad = islds
c
c        nsamps is the no. of samples to display / line
c        ensure nsamps is even so that xdilinewrite will work
c        correctly.
c
         if ( (isad-1) + nsds .gt. maxsamps ) then
          nsamps = maxsamps - isad - 1
         else
          nsamps = nsds
         end if
         nsamps = (( nsamps + 1 ) / 2 ) * 2
c
c        extract the display device no.
c
         jdisid = idisid
         if ( check(1) .eq. vdisid ) then
          ivd    = iv ( bcheck(2) ) - 48
c
c        now the graphics screen
c
         else
          ivd    = gplane
         end if
c
c        read pixels
c
         n    = nlds
         do j = 1, n
          ierr  = xdilineread ( u, ivd, isad, ilad, nsamps, buf )
	  call errors(' xdilineread', ierr)
          ilad = ilad + 1
         end do
         return
c
c----------------------------------------------------------------------------
c
c
c        rcurse/wcurse
c         this is the cursor routine that will read where a cursor is located
c         or position the cursor where the user requests. rcurse is the read
c         routine and wcurse is the write routine.
c
c         where:
c               itid - cursor logical device no.
c               lds  - line coordinate
c               jsds - sample coordinate
c
         entry rcurse ( itid, lds, jsds )
c
         if ( ncurs .eq. 0 ) return
c
c        flip around via autotracking flag
c
         if ( autoflag .eq. 0 ) then
c
c        turn autotracking on
c
           ierr = xdcautotrack ( u, c, 0, .TRUE. )
	   call errors(' xdcautotrack', ierr)
c
c         while the pen is not down and not in proximity
c            read the tablet pen
c
       	  ipen = 0
	  iprox = 0
	  do while ( .not. ( ipen .eq. 1 .and. iprox .eq. 1 ) )
	    ierr = xdx2d( u, 1, cx, cy, iprox, ipen )
	    call errors(' xdx2d', ierr)
	  end do
c
c        find where the cursor is hiding
c
          ierr = xdclocation ( u, c, isds, ilds )
	  call errors(' xdclocation', ierr)
c
c        turn autotracking off
c
           ierr = xdcautotrack ( u, c, 0, .FALSE. )
	   call errors(' xdcautotrack', ierr)
c
c         autotracking on
c
          else
c
c        find where the cursor is hiding
c
           ierr = xdclocation ( u, c, isds, ilds )
	   call errors(' xdclocation', ierr)
          end if
c
c         normal return -
c
           lds  = ilds / dzoom + dlds            ! compensate for panning
           jsds = isds / dzoom + dsds
           return
c
c
c        wcurse
c
c
         entry wcurse ( itid, lds, jsds )
c
         if ( ncurs .eq. 0 ) return
c
         ilds = ( lds - dlds ) * dzoom
         isds = ( jsds- dsds ) * dzoom
         ierr = xdcset (u, c, isds, ilds )
	 call errors(' xdcset', ierr)
c
         return
c
c---------------------------------------------------------------
c
c        pdown
c         this will return a flag = 1 if the
c         pen is down and in proximity
c
         entry pdown ( ipflag )
c
         ipflag = 1
         if ( nintio .eq. 0 ) return
c
            ipen  = 0
	    iprox = 0
 	    ierr  = xdx2d( u, 1, cx, cy, iprox, ipen )
	    call errors(' xdx2d', ierr)
c
          if ( ipen .eq. 1. and .iprox .eq. 1 ) then
           ipflag = 1
          else
           ipflag = 0
          end if
c
          return
c---------------------------------------------------------------
c
c        hzoom
c         this will envoke the hardware zoom
c         option on the DeAnza
c
         entry hzoom ( ihzoom )
c
         do jnmc = 1, 4        ! for all 3 memory planes and the graphics
            irb = jnmc
            ierr = xdizoom ( u, irb, ihzoom )
	    call errors(' xdizoom', ierr)
         end do
c
         dzoom = ihzoom
         return
c---------------------------------------------------------------
c
c        pan
c         this routine will provide pan capabilities for 2048
c         memory planes with a 1024 monitor
c
         entry pan
c
         if ( nintio .eq. 0 ) return       ! if no button - quit here
c
c         if ( icolor .eq. 1 ) then         ! if pseudo color  - quit here
c            call xvmessage('Pan not available in pseudocolor mode',' ')
c            return
c         end if
c
         ilds = 1                          ! set cursor to upper left hand
         isds = 1                          ! corner
         ierr = xdcset (u, c, isds, ilds )
	 call errors(' xdcset', ierr)
c
         prev_auto = autoflag              ! save previous autoflag
         if ( autoflag .eq. 0 ) then       ! turn on autotracking
             autoflag  = 1
             ierr = xdcautotrack ( u, c, 0, autoflag )
	     call errors(' xdcautotrack', ierr)
         end if
c
c        loop until ssw 1 is depressed
c
         ip = 0                            ! button down switch
         do while ( ip .eq. 0 )
             ipen  = 0
     	     iprox = 0
    	     ierr  = xdx2d( u, 1, cx, cy, iprox, ipen )
	     call errors(' xdx2d', ierr)
c
             if ( ipen .eq. 1. and .iprox .eq. 1 ) then
                ip = 1
             else                                        ! still moving
                ip = 0
                ierr = xdclocation ( u, c, isds, ilds )  !find the cursor
		call errors(' xdclocation', ierr)
                do krb = 1, 4                            ! all 4 planes
                    kr = krb
                    ierr = xdidwset ( u, kr, isds, ilds ) ! and pan
		    call errors(' xdidwset', ierr)
                end do
             end if
         end do
c
c        turn autotracking off - if off to start with
c
         if ( prev_auto .ne. autoflag ) then
            ierr = xdcautotrack ( u, c, 0, .FALSE. )
	    call errors(' xdcautotrack', ierr)
         end if
c
         dlds = ilds - 1
         dsds = isds - 1
         return
c
c---------------------------------------------------------------
c
c
c        cset
c         this is the cursor set routine and may be used to
c         control the visibility characteristics of the
c         cursor. it has the following posibilities:
c         a) cursor off
c         b) cursor on
c         the cursor on/off flag , iconoff, has the following values:
c         0 = off
c         1 = on
c         initially, the cursor is set to off.
c
c         in both these cases, the cursor can be blinking
c         or not blinking. obviously, if the cursor is off,
c         we can't see if it is blinking.
c
c         where : itid - logical cursor identifier
c                 key  - cursor visibility characteristics
c                        flag
c                        visi = visible
c                        invi = invisible
c                        blin = blinking
c                        nbli = not blinking
c			 c1   = form 1 (five dots)
c			 c2   = form 2
c	                 c3   = form 3
c
c
         entry cset ( itid, key )

c
         if ( ncurs .eq. 0 ) return
c
c        see if the cursor is alive and visible
c
         if ( key .eq. ikey(1) ) then
          ierr = xdcon ( u, c, iform, iblink )
	  call errors(' xdcon', ierr)
c
c         save cursor visibility flag
c
          iconoff = 1
          return
         end if
c
c        now invisible
c
         if ( key .eq. ikey(2) ) then
          ierr = xdcoff ( u, c )
	  call errors(' xdcoff', ierr)
c
c         save cursor visibility flag
c
          iconoff = 0
          return
         end if
c
c        set the blink on here if the cursor is visible
c
         if ( key .eq. ikey(3) ) then
c
          if ( iconoff .eq. 1 ) then
           iblink = 3
           ierr   = xdcon ( u, c, iform, iblink )
	   call errors(' xdcon', ierr)
           return
c
          else
           iblink = 3
           return
          end if
         end if
c
c        set the blink off here if the cursor is visible
c
         if ( key .eq. ikey(4) ) then
c
          if ( iconoff .eq. 1 ) then
           iblink = 0
           ierr   = xdcon ( u, c, iform, iblink )
	   call errors(' xdcon', ierr)
           return
c
          else
           iblink = 0
           return
          end if
         end if
c
c        set the cursor form to 1 for 'C1'
c
         if ( key .eq. ikey(5) ) then
c
          if ( iconoff .eq. 1 ) then
           iform = 1
           ierr   = xdcon ( u, c, iform, iblink )
	   call errors(' xdcon', ierr)
           return
c
          else
           iform = 1
           return
          end if
         end if
c
c        set the cursor form to 4 for 'C2'
c        set the blink off here if the cursor is visible
c
         if ( key .eq. ikey(6) ) then
c
          if ( iconoff .eq. 1 ) then
           iform = 4
           ierr   = xdcon ( u, c, iform, iblink )
	   call errors(' xdcon', ierr)
           return
c
          else
           iform = 4
           return
          end if
         end if
c
c        set the cursor form to 5 for 'C3'
c
         if ( key .eq. ikey(7) ) then
c
          if ( iconoff .eq. 1 ) then
           iform = 5
           ierr   = xdcon ( u, c, iform, iblink )
	   call errors(' xdcon', ierr)
           return
c
          else
           iform = 5
           return
          end if
         end if
         return
c
c--------------------------------------------------------------
c
c
c        erase
c         this is the routine that erases a screen
c         the screen may either be video or graphics
c
        entry erase(idisid)
c
c       call xdifill to clear the screen, and use
c       the value, v, of zero to blacken the screen.
c
        jdisid = idisid
c
c       first the video screen
c
        if ( check(1) .eq. vdisid ) then
         ivd    = iv ( bcheck(2) ) - 48
         ierr   = xdifill ( u, ivd, v )
	 call errors(' xdifill', ierr)
c
c       now the graphics screen
c
        else
         if ( igraph .eq. 0 ) then
          call xvmessage(ctbl7b,' ')
         else
          ib   = iv ( bcheck(2) ) -48
          gmask  = 2**(ib-1)
          ivd    = gplane
          ierr   = xdimfill ( u, ivd, gmask, v )
	  call errors(' xdimfill', ierr)
         end if
        end if
c
        return
c
c
c----------------------------------------------------------
c
c
c        trkon
c         this is the enable for the track mode.
c         however, at this point this is only a
c         dummy.
c
         entry trkon ( icid )
         call xvmessage(' TRKON - FUNCTION NOT IMPLEMENTED',' ')
         return
c
c        trkoff
c         this is the disable for the track mode.
c         however, at this point this is only a
c         dummy.
c
         entry trkoff ( icid )
         call xvmessage(' TRKOFF - FUNCTION NOT IMPLEMENTED',' ')
         return
c
c        track
c         this is the routine which stores values
c         delimited by the trackball and returns
c         the no. of values stored. it, as the above
c         routines, is also a dummy at the present
c         time.
c
         entry track ( icid, buf, nsamp )
         call xvmessage(' TRACK - FUNCTION NOT IMPLEMENTED',' ')
         return
c
c
c---------------------------------------------------------------------
c
c
c        dset
c         dset appears to be a catch all routine that
c         allows the user to modify the characteristics
c         and display mode of the text as well as
c         update the look up tables. as an added attraction,
c         we also get to connect up lookup tables to image
c         memory planes. this final, more interesting mode
c         is triggered by the fact that itest is none of the
c         more reasonable options. yuck...
c
c         calling sequence ( idisid, itest, larray )
c         where: idisid - logical device
c                itest  - character variation flag
c                         dw = double width
c                         dh = double height
c                         nw = normal width
c                         nh = normal height
c                         po = positive
c                         co = complementary
c                larray - look up table buffer
c
         entry dset ( idisid, itest, larray )
c
         jdisid = idisid
         ivd    = iv ( bcheck(2) ) - 48
c
c        normal display mode.
c
         if ( itest .eq. jkey(5) ) then
           w = ivd
           return
c
c         complimentary display mode
c
         else if ( itest .eq. jkey(6) ) then
           w = 0
           return
c
c        modify the video lookup table
c
         else if ( itest .eq. jkey(7) ) then
           ierr = xdlwrite ( u, ivd, section, larray )
	   call errors(' xdlwrite', ierr)
           return
c
c         and now for something entirely different...
c         height and width
c
c         double the width
c
         else if ( itest .eq. jkey(1) ) then
           s    = 2.0
           ierr = xdtsize ( h, s )
	   call errors(' xdtsize', ierr)
           return
c
c         double the height
c
         else if ( itest .eq. jkey(2) ) then
           if ( lmax .le. 512 ) then
               h = 14
           else
               h = 28
           end if
           ierr = xdtsize ( h, s )
	   call errors(' xdtsize', ierr)
           return
c
c         normal width
c
         else if ( itest .eq. jkey(3) ) then
           s    = 1.0
           ierr = xdtsize ( h, s )
	   call errors(' xdtsize', ierr)
           return
c
c         normal height
c
         else if ( itest .eq. jkey(4) ) then
           if ( lmax .le. 512 ) then
               h = 7
           else
               h = 14
           end if
           ierr = xdtsize ( h, s )
	   call errors(' xdtsize', ierr)
           return
c
c         now connect up lut's to image memory planes
c
         else
           itemp  = idisid
           itemp1 = ichar(itest(1:1))	! probably wrong... rgd 3/2010
c was:	   itemp1 = itest
           ierr   = xdlconnect ( u, itemp, itemp1, 1, .false. )
	   call errors(' xdlconnect', ierr)
           return
         end if
c
        return
        end
c-----------------------------------------------------------------------
c
         subroutine errors ( name, code )
c
         character *(*) name
         integer code
         character*80 msg
c
         if ( code .eq. 1 ) return
c
	 write(msg,100) name,code
  100	 format(a,' returned error =',i3)
	 call xvmessage(msg,' ')
         return
         end

ext: f

max_stars_repo_name: NASA-AMMOS/VICAR

max_issues_repo_name: NASA-AMMOS/VICAR

max_forks_repo_name: NASA-AMMOS/VICAR


!-------------------------------------------------------------------------------
! CODATA_2010_constants.f90
! Automatically generated from 2010 CODATA NIST file:
! https://physics.nist.gov/cuu/Constants/allascii_2010.txt
! downloaded on 2021-03-23.
!-------------------------------------------------------------------------------

module CODATA_2010_constants
  use, intrinsic :: iso_fortran_env, only: wp=>real64
  implicit none

  real(wp), parameter :: twotwozero_lattice_spacing_of_silicon = 192.0155714e-12_wp ! 0.000 0032 e-12  m
  real(wp), parameter :: alpha_particle_electron_mass_ratio = 7294.2995361_wp ! 0.000 0029
  real(wp), parameter :: alpha_particle_mass = 6.64465675e-27_wp ! 0.000 000 29 e-27  kg
  real(wp), parameter :: alpha_particle_mass_energy_equivalent = 5.97191967e-10_wp ! 0.000 000 26 e-10  J
  real(wp), parameter :: alpha_particle_mass_energy_equivalent_in_MeV = 3727.379240_wp ! 0.000 082  MeV
  real(wp), parameter :: alpha_particle_mass_in_u = 4.001506179125_wp ! 0.000 000 000 062  u
  real(wp), parameter :: alpha_particle_molar_mass = 4.001506179125e-3_wp ! 0.000 000 000 062 e-3  kg mol^-1
  real(wp), parameter :: alpha_particle_proton_mass_ratio = 3.97259968933_wp ! 0.000 000 000 36
  real(wp), parameter :: Angstrom_star = 1.00001495e-10_wp ! 0.000 000 90 e-10  m
  real(wp), parameter :: atomic_mass_constant = 1.660538921e-27_wp ! 0.000 000 073 e-27  kg
  real(wp), parameter :: atomic_mass_constant_energy_equivalent = 1.492417954e-10_wp ! 0.000 000 066 e-10  J
  real(wp), parameter :: atomic_mass_constant_energy_equivalent_in_MeV = 931.494061_wp ! 0.000 021  MeV
  real(wp), parameter :: atomic_mass_unit_electron_volt_relationship = 931.494061e6_wp ! 0.000 021 e6  eV
  real(wp), parameter :: atomic_mass_unit_hartree_relationship = 3.4231776845e7_wp ! 0.000 000 0024 e7  E_h
  real(wp), parameter :: atomic_mass_unit_hertz_relationship = 2.2523427168e23_wp ! 0.000 000 0016 e23  Hz
  real(wp), parameter :: atomic_mass_unit_inverse_meter_relationship = 7.5130066042e14_wp ! 0.000 000 0053 e14  m^-1
  real(wp), parameter :: atomic_mass_unit_joule_relationship = 1.492417954e-10_wp ! 0.000 000 066 e-10  J
  real(wp), parameter :: atomic_mass_unit_kelvin_relationship = 1.08095408e13_wp ! 0.000 000 98 e13  K
  real(wp), parameter :: atomic_mass_unit_kilogram_relationship = 1.660538921e-27_wp ! 0.000 000 073 e-27  kg
  real(wp), parameter :: atomic_unit_of_1st_hyperpolarizability = 3.206361449e-53_wp ! 0.000 000 071 e-53  C^3 m^3 J^-2
  real(wp), parameter :: atomic_unit_of_2nd_hyperpolarizability = 6.23538054e-65_wp ! 0.000 000 28 e-65  C^4 m^4 J^-3
  real(wp), parameter :: atomic_unit_of_action = 1.054571726e-34_wp ! 0.000 000 047 e-34  J s
  real(wp), parameter :: atomic_unit_of_charge = 1.602176565e-19_wp ! 0.000 000 035 e-19  C
  real(wp), parameter :: atomic_unit_of_charge_density = 1.081202338e12_wp ! 0.000 000 024 e12  C m^-3
  real(wp), parameter :: atomic_unit_of_current = 6.62361795e-3_wp ! 0.000 000 15 e-3  A
  real(wp), parameter :: atomic_unit_of_electric_dipole_mom_ = 8.47835326e-30_wp ! 0.000 000 19 e-30  C m
  real(wp), parameter :: atomic_unit_of_electric_field = 5.14220652e11_wp ! 0.000 000 11 e11  V m^-1
  real(wp), parameter :: atomic_unit_of_electric_field_gradient = 9.71736200e21_wp ! 0.000 000 21 e21  V m^-2
  real(wp), parameter :: atomic_unit_of_electric_polarizability = 1.6487772754e-41_wp ! 0.000 000 0016 e-41  C^2 m^2 J^-1
  real(wp), parameter :: atomic_unit_of_electric_potential = 27.21138505_wp ! 0.000 000 60  V
  real(wp), parameter :: atomic_unit_of_electric_quadrupole_mom_ = 4.486551331e-40_wp ! 0.000 000 099 e-40  C m^2
  real(wp), parameter :: atomic_unit_of_energy = 4.35974434e-18_wp ! 0.000 000 19 e-18  J
  real(wp), parameter :: atomic_unit_of_force = 8.23872278e-8_wp ! 0.000 000 36 e-8  N
  real(wp), parameter :: atomic_unit_of_length = 0.52917721092e-10_wp ! 0.000 000 000 17 e-10  m
  real(wp), parameter :: atomic_unit_of_mag__dipole_mom_ = 1.854801936e-23_wp ! 0.000 000 041 e-23  J T^-1
  real(wp), parameter :: atomic_unit_of_mag__flux_density = 2.350517464e5_wp ! 0.000 000 052 e5  T
  real(wp), parameter :: atomic_unit_of_magnetizability = 7.891036607e-29_wp ! 0.000 000 013 e-29  J T^-2
  real(wp), parameter :: atomic_unit_of_mass = 9.10938291e-31_wp ! 0.000 000 40 e-31  kg
  real(wp), parameter :: atomic_unit_of_mom_um = 1.992851740e-24_wp ! 0.000 000 088 e-24  kg m s^-1
  real(wp), parameter :: atomic_unit_of_permittivity = 1.112650056e-10_wp ! (exact)  F m^-1
  real(wp), parameter :: atomic_unit_of_time = 2.418884326502e-17_wp ! 0.000 000 000 012 e-17  s
  real(wp), parameter :: atomic_unit_of_velocity = 2.18769126379e6_wp ! 0.000 000 000 71 e6  m s^-1
  real(wp), parameter :: Avogadro_constant = 6.02214129e23_wp ! 0.000 000 27 e23  mol^-1
  real(wp), parameter :: Bohr_magneton = 927.400968e-26_wp ! 0.000 020 e-26  J T^-1
  real(wp), parameter :: Bohr_magneton_in_eV_T = 5.7883818066e-5_wp ! 0.000 000 0038 e-5  eV T^-1
  real(wp), parameter :: Bohr_magneton_in_Hz_T = 13.99624555e9_wp ! 0.000 000 31 e9  Hz T^-1
  real(wp), parameter :: Bohr_magneton_in_inverse_meters_per_tesla = 46.6864498_wp ! 0.000 0010  m^-1 T^-1
  real(wp), parameter :: Bohr_magneton_in_K_T = 0.67171388_wp ! 0.000 000 61  K T^-1
  real(wp), parameter :: Bohr_radius = 0.52917721092e-10_wp ! 0.000 000 000 17 e-10  m
  real(wp), parameter :: Boltzmann_constant = 1.3806488e-23_wp ! 0.000 0013 e-23  J K^-1
  real(wp), parameter :: Boltzmann_constant_in_eV_K = 8.6173324e-5_wp ! 0.000 0078 e-5  eV K^-1
  real(wp), parameter :: Boltzmann_constant_in_Hz_K = 2.0836618e10_wp ! 0.000 0019 e10  Hz K^-1
  real(wp), parameter :: Boltzmann_constant_in_inverse_meters_per_kelvin = 69.503476_wp ! 0.000 063  m^-1 K^-1
  real(wp), parameter :: characteristic_impedance_of_vacuum = 376.730313461_wp ! (exact)  ohm
  real(wp), parameter :: classical_electron_radius = 2.8179403267e-15_wp ! 0.000 000 0027 e-15  m
  real(wp), parameter :: Compton_wavelength = 2.4263102389e-12_wp ! 0.000 000 0016 e-12  m
  real(wp), parameter :: Compton_wavelength_over_2_pi = 386.15926800e-15_wp ! 0.000 000 25 e-15  m
  real(wp), parameter :: conductance_quantum = 7.7480917346e-5_wp ! 0.000 000 0025 e-5  S
  real(wp), parameter :: conventional_value_of_Josephson_constant = 483597.9e9_wp ! (exact)  Hz V^-1
  real(wp), parameter :: conventional_value_of_von_Klitzing_constant = 25812.807_wp ! (exact)  ohm
  real(wp), parameter :: Cu_x_unit = 1.00207697e-13_wp ! 0.000 000 28 e-13  m
  real(wp), parameter :: deuteron_electron_mag__mom__ratio = -4.664345537e-4_wp ! 0.000 000 039 e-4
  real(wp), parameter :: deuteron_electron_mass_ratio = 3670.4829652_wp ! 0.000 0015
  real(wp), parameter :: deuteron_g_factor = 0.8574382308_wp ! 0.000 000 0072
  real(wp), parameter :: deuteron_mag__mom_ = 0.433073489e-26_wp ! 0.000 000 010 e-26  J T^-1
  real(wp), parameter :: deuteron_mag__mom__to_Bohr_magneton_ratio = 0.4669754556e-3_wp ! 0.000 000 0039 e-3
  real(wp), parameter :: deuteron_mag__mom__to_nuclear_magneton_ratio = 0.8574382308_wp ! 0.000 000 0072
  real(wp), parameter :: deuteron_mass = 3.34358348e-27_wp ! 0.000 000 15 e-27  kg
  real(wp), parameter :: deuteron_mass_energy_equivalent = 3.00506297e-10_wp ! 0.000 000 13 e-10  J
  real(wp), parameter :: deuteron_mass_energy_equivalent_in_MeV = 1875.612859_wp ! 0.000 041  MeV
  real(wp), parameter :: deuteron_mass_in_u = 2.013553212712_wp ! 0.000 000 000 077  u
  real(wp), parameter :: deuteron_molar_mass = 2.013553212712e-3_wp ! 0.000 000 000 077 e-3  kg mol^-1
  real(wp), parameter :: deuteron_neutron_mag__mom__ratio = -0.44820652_wp ! 0.000 000 11
  real(wp), parameter :: deuteron_proton_mag__mom__ratio = 0.3070122070_wp ! 0.000 000 0024
  real(wp), parameter :: deuteron_proton_mass_ratio = 1.99900750097_wp ! 0.000 000 000 18
  real(wp), parameter :: deuteron_rms_charge_radius = 2.1424e-15_wp ! 0.0021 e-15  m
  real(wp), parameter :: electric_constant = 8.854187817e-12_wp ! (exact)  F m^-1
  real(wp), parameter :: electron_charge_to_mass_quotient = -1.758820088e11_wp ! 0.000 000 039 e11  C kg^-1
  real(wp), parameter :: electron_deuteron_mag__mom__ratio = -2143.923498_wp ! 0.000 018
  real(wp), parameter :: electron_deuteron_mass_ratio = 2.7244371095e-4_wp ! 0.000 000 0011 e-4
  real(wp), parameter :: electron_g_factor = -2.00231930436153_wp ! 0.000 000 000 000 53
  real(wp), parameter :: electron_gyromag__ratio = 1.760859708e11_wp ! 0.000 000 039 e11  s^-1 T^-1
  real(wp), parameter :: electron_gyromag__ratio_over_2_pi = 28024.95266_wp ! 0.000 62  MHz T^-1
  real(wp), parameter :: electron_helion_mass_ratio = 1.8195430761e-4_wp ! 0.000 000 0017 e-4
  real(wp), parameter :: electron_mag__mom_ = -928.476430e-26_wp ! 0.000 021 e-26  J T^-1
  real(wp), parameter :: electron_mag__mom__anomaly = 1.15965218076e-3_wp ! 0.000 000 000 27 e-3
  real(wp), parameter :: electron_mag__mom__to_Bohr_magneton_ratio = -1.00115965218076_wp ! 0.000 000 000 000 27
  real(wp), parameter :: electron_mag__mom__to_nuclear_magneton_ratio = -1838.28197090_wp ! 0.000 000 75
  real(wp), parameter :: electron_mass = 9.10938291e-31_wp ! 0.000 000 40 e-31  kg
  real(wp), parameter :: electron_mass_energy_equivalent = 8.18710506e-14_wp ! 0.000 000 36 e-14  J
  real(wp), parameter :: electron_mass_energy_equivalent_in_MeV = 0.510998928_wp ! 0.000 000 011  MeV
  real(wp), parameter :: electron_mass_in_u = 5.4857990946e-4_wp ! 0.000 000 0022 e-4  u
  real(wp), parameter :: electron_molar_mass = 5.4857990946e-7_wp ! 0.000 000 0022 e-7  kg mol^-1
  real(wp), parameter :: electron_muon_mag__mom__ratio = 206.7669896_wp ! 0.000 0052
  real(wp), parameter :: electron_muon_mass_ratio = 4.83633166e-3_wp ! 0.000 000 12 e-3
  real(wp), parameter :: electron_neutron_mag__mom__ratio = 960.92050_wp ! 0.000 23
  real(wp), parameter :: electron_neutron_mass_ratio = 5.4386734461e-4_wp ! 0.000 000 0032 e-4
  real(wp), parameter :: electron_proton_mag__mom__ratio = -658.2106848_wp ! 0.000 0054
  real(wp), parameter :: electron_proton_mass_ratio = 5.4461702178e-4_wp ! 0.000 000 0022 e-4
  real(wp), parameter :: electron_tau_mass_ratio = 2.87592e-4_wp ! 0.000 26 e-4
  real(wp), parameter :: electron_to_alpha_particle_mass_ratio = 1.37093355578e-4_wp ! 0.000 000 000 55 e-4
  real(wp), parameter :: electron_to_shielded_helion_mag__mom__ratio = 864.058257_wp ! 0.000 010
  real(wp), parameter :: electron_to_shielded_proton_mag__mom__ratio = -658.2275971_wp ! 0.000 0072
  real(wp), parameter :: electron_triton_mass_ratio = 1.8192000653e-4_wp ! 0.000 000 0017 e-4
  real(wp), parameter :: electron_volt = 1.602176565e-19_wp ! 0.000 000 035 e-19  J
  real(wp), parameter :: electron_volt_atomic_mass_unit_relationship = 1.073544150e-9_wp ! 0.000 000 024 e-9  u
  real(wp), parameter :: electron_volt_hartree_relationship = 3.674932379e-2_wp ! 0.000 000 081 e-2  E_h
  real(wp), parameter :: electron_volt_hertz_relationship = 2.417989348e14_wp ! 0.000 000 053 e14  Hz
  real(wp), parameter :: electron_volt_inverse_meter_relationship = 8.06554429e5_wp ! 0.000 000 18 e5  m^-1
  real(wp), parameter :: electron_volt_joule_relationship = 1.602176565e-19_wp ! 0.000 000 035 e-19  J
  real(wp), parameter :: electron_volt_kelvin_relationship = 1.1604519e4_wp ! 0.000 0011 e4  K
  real(wp), parameter :: electron_volt_kilogram_relationship = 1.782661845e-36_wp ! 0.000 000 039 e-36  kg
  real(wp), parameter :: elementary_charge = 1.602176565e-19_wp ! 0.000 000 035 e-19  C
  real(wp), parameter :: elementary_charge_over_h = 2.417989348e14_wp ! 0.000 000 053 e14  A J^-1
  real(wp), parameter :: Faraday_constant = 96485.3365_wp ! 0.0021  C mol^-1
  real(wp), parameter :: Faraday_constant_for_conventional_electric_current = 96485.3321_wp ! 0.0043  C_90 mol^-1
  real(wp), parameter :: Fermi_coupling_constant = 1.166364e-5_wp ! 0.000 005 e-5  GeV^-2
  real(wp), parameter :: fine_structure_constant = 7.2973525698e-3_wp ! 0.000 000 0024 e-3
  real(wp), parameter :: first_radiation_constant = 3.74177153e-16_wp ! 0.000 000 17 e-16  W m^2
  real(wp), parameter :: first_radiation_constant_for_spectral_radiance = 1.191042869e-16_wp ! 0.000 000 053 e-16  W m^2 sr^-1
  real(wp), parameter :: hartree_atomic_mass_unit_relationship = 2.9212623246e-8_wp ! 0.000 000 0021 e-8  u
  real(wp), parameter :: hartree_electron_volt_relationship = 27.21138505_wp ! 0.000 000 60  eV
  real(wp), parameter :: Hartree_energy = 4.35974434e-18_wp ! 0.000 000 19 e-18  J
  real(wp), parameter :: Hartree_energy_in_eV = 27.21138505_wp ! 0.000 000 60  eV
  real(wp), parameter :: hartree_hertz_relationship = 6.579683920729e15_wp ! 0.000 000 000 033 e15  Hz
  real(wp), parameter :: hartree_inverse_meter_relationship = 2.194746313708e7_wp ! 0.000 000 000 011 e7  m^-1
  real(wp), parameter :: hartree_joule_relationship = 4.35974434e-18_wp ! 0.000 000 19 e-18  J
  real(wp), parameter :: hartree_kelvin_relationship = 3.1577504e5_wp ! 0.000 0029 e5  K
  real(wp), parameter :: hartree_kilogram_relationship = 4.85086979e-35_wp ! 0.000 000 21 e-35  kg
  real(wp), parameter :: helion_electron_mass_ratio = 5495.8852754_wp ! 0.000 0050
  real(wp), parameter :: helion_g_factor = -4.255250613_wp ! 0.000 000 050
  real(wp), parameter :: helion_mag__mom_ = -1.074617486e-26_wp ! 0.000 000 027 e-26  J T^-1
  real(wp), parameter :: helion_mag__mom__to_Bohr_magneton_ratio = -1.158740958e-3_wp ! 0.000 000 014 e-3
  real(wp), parameter :: helion_mag__mom__to_nuclear_magneton_ratio = -2.127625306_wp ! 0.000 000 025
  real(wp), parameter :: helion_mass = 5.00641234e-27_wp ! 0.000 000 22 e-27  kg
  real(wp), parameter :: helion_mass_energy_equivalent = 4.49953902e-10_wp ! 0.000 000 20 e-10  J
  real(wp), parameter :: helion_mass_energy_equivalent_in_MeV = 2808.391482_wp ! 0.000 062  MeV
  real(wp), parameter :: helion_mass_in_u = 3.0149322468_wp ! 0.000 000 0025  u
  real(wp), parameter :: helion_molar_mass = 3.0149322468e-3_wp ! 0.000 000 0025 e-3  kg mol^-1
  real(wp), parameter :: helion_proton_mass_ratio = 2.9931526707_wp ! 0.000 000 0025
  real(wp), parameter :: hertz_atomic_mass_unit_relationship = 4.4398216689e-24_wp ! 0.000 000 0031 e-24  u
  real(wp), parameter :: hertz_electron_volt_relationship = 4.135667516e-15_wp ! 0.000 000 091 e-15  eV
  real(wp), parameter :: hertz_hartree_relationship = 1.5198298460045e-16_wp ! 0.000 000 000 0076 e-16  E_h
  real(wp), parameter :: hertz_inverse_meter_relationship = 3.335640951e-9_wp ! (exact)  m^-1
  real(wp), parameter :: hertz_joule_relationship = 6.62606957e-34_wp ! 0.000 000 29 e-34  J
  real(wp), parameter :: hertz_kelvin_relationship = 4.7992434e-11_wp ! 0.000 0044 e-11  K
  real(wp), parameter :: hertz_kilogram_relationship = 7.37249668e-51_wp ! 0.000 000 33 e-51  kg
  real(wp), parameter :: inverse_fine_structure_constant = 137.035999074_wp ! 0.000 000 044
  real(wp), parameter :: inverse_meter_atomic_mass_unit_relationship = 1.33102505120e-15_wp ! 0.000 000 000 94 e-15  u
  real(wp), parameter :: inverse_meter_electron_volt_relationship = 1.239841930e-6_wp ! 0.000 000 027 e-6  eV
  real(wp), parameter :: inverse_meter_hartree_relationship = 4.556335252755e-8_wp ! 0.000 000 000 023 e-8  E_h
  real(wp), parameter :: inverse_meter_hertz_relationship = 299792458e0_wp ! (exact)  Hz
  real(wp), parameter :: inverse_meter_joule_relationship = 1.986445684e-25_wp ! 0.000 000 088 e-25  J
  real(wp), parameter :: inverse_meter_kelvin_relationship = 1.4387770e-2_wp ! 0.000 0013 e-2  K
  real(wp), parameter :: inverse_meter_kilogram_relationship = 2.210218902e-42_wp ! 0.000 000 098 e-42  kg
  real(wp), parameter :: inverse_of_conductance_quantum = 12906.4037217_wp ! 0.000 0042  ohm
  real(wp), parameter :: Josephson_constant = 483597.870e9_wp ! 0.011 e9  Hz V^-1
  real(wp), parameter :: joule_atomic_mass_unit_relationship = 6.70053585e9_wp ! 0.000 000 30 e9  u
  real(wp), parameter :: joule_electron_volt_relationship = 6.24150934e18_wp ! 0.000 000 14 e18  eV
  real(wp), parameter :: joule_hartree_relationship = 2.29371248e17_wp ! 0.000 000 10 e17  E_h
  real(wp), parameter :: joule_hertz_relationship = 1.509190311e33_wp ! 0.000 000 067 e33  Hz
  real(wp), parameter :: joule_inverse_meter_relationship = 5.03411701e24_wp ! 0.000 000 22 e24  m^-1
  real(wp), parameter :: joule_kelvin_relationship = 7.2429716e22_wp ! 0.000 0066 e22  K
  real(wp), parameter :: joule_kilogram_relationship = 1.112650056e-17_wp ! (exact)  kg
  real(wp), parameter :: kelvin_atomic_mass_unit_relationship = 9.2510868e-14_wp ! 0.000 0084 e-14  u
  real(wp), parameter :: kelvin_electron_volt_relationship = 8.6173324e-5_wp ! 0.000 0078 e-5  eV
  real(wp), parameter :: kelvin_hartree_relationship = 3.1668114e-6_wp ! 0.000 0029 e-6  E_h
  real(wp), parameter :: kelvin_hertz_relationship = 2.0836618e10_wp ! 0.000 0019 e10  Hz
  real(wp), parameter :: kelvin_inverse_meter_relationship = 69.503476_wp ! 0.000 063  m^-1
  real(wp), parameter :: kelvin_joule_relationship = 1.3806488e-23_wp ! 0.000 0013 e-23  J
  real(wp), parameter :: kelvin_kilogram_relationship = 1.5361790e-40_wp ! 0.000 0014 e-40  kg
  real(wp), parameter :: kilogram_atomic_mass_unit_relationship = 6.02214129e26_wp ! 0.000 000 27 e26  u
  real(wp), parameter :: kilogram_electron_volt_relationship = 5.60958885e35_wp ! 0.000 000 12 e35  eV
  real(wp), parameter :: kilogram_hartree_relationship = 2.061485968e34_wp ! 0.000 000 091 e34  E_h
  real(wp), parameter :: kilogram_hertz_relationship = 1.356392608e50_wp ! 0.000 000 060 e50  Hz
  real(wp), parameter :: kilogram_inverse_meter_relationship = 4.52443873e41_wp ! 0.000 000 20 e41  m^-1
  real(wp), parameter :: kilogram_joule_relationship = 8.987551787e16_wp ! (exact)  J
  real(wp), parameter :: kilogram_kelvin_relationship = 6.5096582e39_wp ! 0.000 0059 e39  K
  real(wp), parameter :: lattice_parameter_of_silicon = 543.1020504e-12_wp ! 0.000 0089 e-12  m
  real(wp), parameter :: Loschmidt_constant_273_15_K__100_kPa = 2.6516462e25_wp ! 0.000 0024 e25  m^-3
  real(wp), parameter :: Loschmidt_constant_273_15_K__101_325_kPa = 2.6867805e25_wp ! 0.000 0024 e25  m^-3
  real(wp), parameter :: mag__constant = 12.566370614e-7_wp ! (exact)  N A^-2
  real(wp), parameter :: mag__flux_quantum = 2.067833758e-15_wp ! 0.000 000 046 e-15  Wb
  real(wp), parameter :: molar_gas_constant = 8.3144621_wp ! 0.000 0075  J mol^-1 K^-1
  real(wp), parameter :: molar_mass_constant = 1e-3_wp ! (exact)  kg mol^-1
  real(wp), parameter :: molar_mass_of_carbon_12 = 12e-3_wp ! (exact)  kg mol^-1
  real(wp), parameter :: molar_Planck_constant = 3.9903127176e-10_wp ! 0.000 000 0028 e-10  J s mol^-1
  real(wp), parameter :: molar_Planck_constant_times_c = 0.119626565779_wp ! 0.000 000 000 084  J m mol^-1
  real(wp), parameter :: molar_volume_of_ideal_gas_273_15_K__100_kPa = 22.710953e-3_wp ! 0.000 021 e-3  m^3 mol^-1
  real(wp), parameter :: molar_volume_of_ideal_gas_273_15_K__101_325_kPa = 22.413968e-3_wp ! 0.000 020 e-3  m^3 mol^-1
  real(wp), parameter :: molar_volume_of_silicon = 12.05883301e-6_wp ! 0.000 000 80 e-6  m^3 mol^-1
  real(wp), parameter :: Mo_x_unit = 1.00209952e-13_wp ! 0.000 000 53 e-13  m
  real(wp), parameter :: muon_Compton_wavelength = 11.73444103e-15_wp ! 0.000 000 30 e-15  m
  real(wp), parameter :: muon_Compton_wavelength_over_2_pi = 1.867594294e-15_wp ! 0.000 000 047 e-15  m
  real(wp), parameter :: muon_electron_mass_ratio = 206.7682843_wp ! 0.000 0052
  real(wp), parameter :: muon_g_factor = -2.0023318418_wp ! 0.000 000 0013
  real(wp), parameter :: muon_mag__mom_ = -4.49044807e-26_wp ! 0.000 000 15 e-26  J T^-1
  real(wp), parameter :: muon_mag__mom__anomaly = 1.16592091e-3_wp ! 0.000 000 63 e-3
  real(wp), parameter :: muon_mag__mom__to_Bohr_magneton_ratio = -4.84197044e-3_wp ! 0.000 000 12 e-3
  real(wp), parameter :: muon_mag__mom__to_nuclear_magneton_ratio = -8.89059697_wp ! 0.000 000 22
  real(wp), parameter :: muon_mass = 1.883531475e-28_wp ! 0.000 000 096 e-28  kg
  real(wp), parameter :: muon_mass_energy_equivalent = 1.692833667e-11_wp ! 0.000 000 086 e-11  J
  real(wp), parameter :: muon_mass_energy_equivalent_in_MeV = 105.6583715_wp ! 0.000 0035  MeV
  real(wp), parameter :: muon_mass_in_u = 0.1134289267_wp ! 0.000 000 0029  u
  real(wp), parameter :: muon_molar_mass = 0.1134289267e-3_wp ! 0.000 000 0029 e-3  kg mol^-1
  real(wp), parameter :: muon_neutron_mass_ratio = 0.1124545177_wp ! 0.000 000 0028
  real(wp), parameter :: muon_proton_mag__mom__ratio = -3.183345107_wp ! 0.000 000 084
  real(wp), parameter :: muon_proton_mass_ratio = 0.1126095272_wp ! 0.000 000 0028
  real(wp), parameter :: muon_tau_mass_ratio = 5.94649e-2_wp ! 0.000 54 e-2
  real(wp), parameter :: natural_unit_of_action = 1.054571726e-34_wp ! 0.000 000 047 e-34  J s
  real(wp), parameter :: natural_unit_of_action_in_eV_s = 6.58211928e-16_wp ! 0.000 000 15 e-16  eV s
  real(wp), parameter :: natural_unit_of_energy = 8.18710506e-14_wp ! 0.000 000 36 e-14  J
  real(wp), parameter :: natural_unit_of_energy_in_MeV = 0.510998928_wp ! 0.000 000 011  MeV
  real(wp), parameter :: natural_unit_of_length = 386.15926800e-15_wp ! 0.000 000 25 e-15  m
  real(wp), parameter :: natural_unit_of_mass = 9.10938291e-31_wp ! 0.000 000 40 e-31  kg
  real(wp), parameter :: natural_unit_of_mom_um = 2.73092429e-22_wp ! 0.000 000 12 e-22  kg m s^-1
  real(wp), parameter :: natural_unit_of_mom_um_in_MeV_c = 0.510998928_wp ! 0.000 000 011  MeV/c
  real(wp), parameter :: natural_unit_of_time = 1.28808866833e-21_wp ! 0.000 000 000 83 e-21  s
  real(wp), parameter :: natural_unit_of_velocity = 299792458e0_wp ! (exact)  m s^-1
  real(wp), parameter :: neutron_Compton_wavelength = 1.3195909068e-15_wp ! 0.000 000 0011 e-15  m
  real(wp), parameter :: neutron_Compton_wavelength_over_2_pi = 0.21001941568e-15_wp ! 0.000 000 000 17 e-15  m
  real(wp), parameter :: neutron_electron_mag__mom__ratio = 1.04066882e-3_wp ! 0.000 000 25 e-3
  real(wp), parameter :: neutron_electron_mass_ratio = 1838.6836605_wp ! 0.000 0011
  real(wp), parameter :: neutron_g_factor = -3.82608545_wp ! 0.000 000 90
  real(wp), parameter :: neutron_gyromag__ratio = 1.83247179e8_wp ! 0.000 000 43 e8  s^-1 T^-1
  real(wp), parameter :: neutron_gyromag__ratio_over_2_pi = 29.1646943_wp ! 0.000 0069  MHz T^-1
  real(wp), parameter :: neutron_mag__mom_ = -0.96623647e-26_wp ! 0.000 000 23 e-26  J T^-1
  real(wp), parameter :: neutron_mag__mom__to_Bohr_magneton_ratio = -1.04187563e-3_wp ! 0.000 000 25 e-3
  real(wp), parameter :: neutron_mag__mom__to_nuclear_magneton_ratio = -1.91304272_wp ! 0.000 000 45
  real(wp), parameter :: neutron_mass = 1.674927351e-27_wp ! 0.000 000 074 e-27  kg
  real(wp), parameter :: neutron_mass_energy_equivalent = 1.505349631e-10_wp ! 0.000 000 066 e-10  J
  real(wp), parameter :: neutron_mass_energy_equivalent_in_MeV = 939.565379_wp ! 0.000 021  MeV
  real(wp), parameter :: neutron_mass_in_u = 1.00866491600_wp ! 0.000 000 000 43  u
  real(wp), parameter :: neutron_molar_mass = 1.00866491600e-3_wp ! 0.000 000 000 43 e-3  kg mol^-1
  real(wp), parameter :: neutron_muon_mass_ratio = 8.89248400_wp ! 0.000 000 22
  real(wp), parameter :: neutron_proton_mag__mom__ratio = -0.68497934_wp ! 0.000 000 16
  real(wp), parameter :: neutron_proton_mass_difference = 2.30557392e-30_wp ! 0.000 000 76 e-30
  real(wp), parameter :: neutron_proton_mass_difference_energy_equivalent = 2.07214650e-13_wp ! 0.000 000 68 e-13
  real(wp), parameter :: neutron_proton_mass_difference_energy_equivalent_in_MeV = 1.29333217_wp ! 0.000 000 42
  real(wp), parameter :: neutron_proton_mass_difference_in_u = 0.00138844919_wp ! 0.000 000 000 45
  real(wp), parameter :: neutron_proton_mass_ratio = 1.00137841917_wp ! 0.000 000 000 45
  real(wp), parameter :: neutron_tau_mass_ratio = 0.528790_wp ! 0.000 048
  real(wp), parameter :: neutron_to_shielded_proton_mag__mom__ratio = -0.68499694_wp ! 0.000 000 16
  real(wp), parameter :: Newtonian_constant_of_gravitation = 6.67384e-11_wp ! 0.000 80 e-11  m^3 kg^-1 s^-2
  real(wp), parameter :: Newtonian_constant_of_gravitation_over_h_bar_c = 6.70837e-39_wp ! 0.000 80 e-39  (GeV/c^2)^-2
  real(wp), parameter :: nuclear_magneton = 5.05078353e-27_wp ! 0.000 000 11 e-27  J T^-1
  real(wp), parameter :: nuclear_magneton_in_eV_T = 3.1524512605e-8_wp ! 0.000 000 0022 e-8  eV T^-1
  real(wp), parameter :: nuclear_magneton_in_inverse_meters_per_tesla = 2.542623527e-2_wp ! 0.000 000 056 e-2  m^-1 T^-1
  real(wp), parameter :: nuclear_magneton_in_K_T = 3.6582682e-4_wp ! 0.000 0033 e-4  K T^-1
  real(wp), parameter :: nuclear_magneton_in_MHz_T = 7.62259357_wp ! 0.000 000 17  MHz T^-1
  real(wp), parameter :: Planck_constant = 6.62606957e-34_wp ! 0.000 000 29 e-34  J s
  real(wp), parameter :: Planck_constant_in_eV_s = 4.135667516e-15_wp ! 0.000 000 091 e-15  eV s
  real(wp), parameter :: Planck_constant_over_2_pi = 1.054571726e-34_wp ! 0.000 000 047 e-34  J s
  real(wp), parameter :: Planck_constant_over_2_pi_in_eV_s = 6.58211928e-16_wp ! 0.000 000 15 e-16  eV s
  real(wp), parameter :: Planck_constant_over_2_pi_times_c_in_MeV_fm = 197.3269718_wp ! 0.000 0044  MeV fm
  real(wp), parameter :: Planck_length = 1.616199e-35_wp ! 0.000 097 e-35  m
  real(wp), parameter :: Planck_mass = 2.17651e-8_wp ! 0.000 13 e-8  kg
  real(wp), parameter :: Planck_mass_energy_equivalent_in_GeV = 1.220932e19_wp ! 0.000 073 e19  GeV
  real(wp), parameter :: Planck_temperature = 1.416833e32_wp ! 0.000 085 e32  K
  real(wp), parameter :: Planck_time = 5.39106e-44_wp ! 0.000 32 e-44  s
  real(wp), parameter :: proton_charge_to_mass_quotient = 9.57883358e7_wp ! 0.000 000 21 e7  C kg^-1
  real(wp), parameter :: proton_Compton_wavelength = 1.32140985623e-15_wp ! 0.000 000 000 94 e-15  m
  real(wp), parameter :: proton_Compton_wavelength_over_2_pi = 0.21030891047e-15_wp ! 0.000 000 000 15 e-15  m
  real(wp), parameter :: proton_electron_mass_ratio = 1836.15267245_wp ! 0.000 000 75
  real(wp), parameter :: proton_g_factor = 5.585694713_wp ! 0.000 000 046
  real(wp), parameter :: proton_gyromag__ratio = 2.675222005e8_wp ! 0.000 000 063 e8  s^-1 T^-1
  real(wp), parameter :: proton_gyromag__ratio_over_2_pi = 42.5774806_wp ! 0.000 0010  MHz T^-1
  real(wp), parameter :: proton_mag__mom_ = 1.410606743e-26_wp ! 0.000 000 033 e-26  J T^-1
  real(wp), parameter :: proton_mag__mom__to_Bohr_magneton_ratio = 1.521032210e-3_wp ! 0.000 000 012 e-3
  real(wp), parameter :: proton_mag__mom__to_nuclear_magneton_ratio = 2.792847356_wp ! 0.000 000 023
  real(wp), parameter :: proton_mag__shielding_correction = 25.694e-6_wp ! 0.014 e-6
  real(wp), parameter :: proton_mass = 1.672621777e-27_wp ! 0.000 000 074 e-27  kg
  real(wp), parameter :: proton_mass_energy_equivalent = 1.503277484e-10_wp ! 0.000 000 066 e-10  J
  real(wp), parameter :: proton_mass_energy_equivalent_in_MeV = 938.272046_wp ! 0.000 021  MeV
  real(wp), parameter :: proton_mass_in_u = 1.007276466812_wp ! 0.000 000 000 090  u
  real(wp), parameter :: proton_molar_mass = 1.007276466812e-3_wp ! 0.000 000 000 090 e-3  kg mol^-1
  real(wp), parameter :: proton_muon_mass_ratio = 8.88024331_wp ! 0.000 000 22
  real(wp), parameter :: proton_neutron_mag__mom__ratio = -1.45989806_wp ! 0.000 000 34
  real(wp), parameter :: proton_neutron_mass_ratio = 0.99862347826_wp ! 0.000 000 000 45
  real(wp), parameter :: proton_rms_charge_radius = 0.8775e-15_wp ! 0.0051 e-15  m
  real(wp), parameter :: proton_tau_mass_ratio = 0.528063_wp ! 0.000 048
  real(wp), parameter :: quantum_of_circulation = 3.6369475520e-4_wp ! 0.000 000 0024 e-4  m^2 s^-1
  real(wp), parameter :: quantum_of_circulation_times_2 = 7.2738951040e-4_wp ! 0.000 000 0047 e-4  m^2 s^-1
  real(wp), parameter :: Rydberg_constant = 10973731.568539_wp ! 0.000 055  m^-1
  real(wp), parameter :: Rydberg_constant_times_c_in_Hz = 3.289841960364e15_wp ! 0.000 000 000 017 e15  Hz
  real(wp), parameter :: Rydberg_constant_times_hc_in_eV = 13.60569253_wp ! 0.000 000 30  eV
  real(wp), parameter :: Rydberg_constant_times_hc_in_J = 2.179872171e-18_wp ! 0.000 000 096 e-18  J
  real(wp), parameter :: Sackur_Tetrode_constant_1_K__100_kPa = -1.1517078_wp ! 0.000 0023
  real(wp), parameter :: Sackur_Tetrode_constant_1_K__101_325_kPa = -1.1648708_wp ! 0.000 0023
  real(wp), parameter :: second_radiation_constant = 1.4387770e-2_wp ! 0.000 0013 e-2  m K
  real(wp), parameter :: shielded_helion_gyromag__ratio = 2.037894659e8_wp ! 0.000 000 051 e8  s^-1 T^-1
  real(wp), parameter :: shielded_helion_gyromag__ratio_over_2_pi = 32.43410084_wp ! 0.000 000 81  MHz T^-1
  real(wp), parameter :: shielded_helion_mag__mom_ = -1.074553044e-26_wp ! 0.000 000 027 e-26  J T^-1
  real(wp), parameter :: shielded_helion_mag__mom__to_Bohr_magneton_ratio = -1.158671471e-3_wp ! 0.000 000 014 e-3
  real(wp), parameter :: shielded_helion_mag__mom__to_nuclear_magneton_ratio = -2.127497718_wp ! 0.000 000 025
  real(wp), parameter :: shielded_helion_to_proton_mag__mom__ratio = -0.761766558_wp ! 0.000 000 011
  real(wp), parameter :: shielded_helion_to_shielded_proton_mag__mom__ratio = -0.7617861313_wp ! 0.000 000 0033
  real(wp), parameter :: shielded_proton_gyromag__ratio = 2.675153268e8_wp ! 0.000 000 066 e8  s^-1 T^-1
  real(wp), parameter :: shielded_proton_gyromag__ratio_over_2_pi = 42.5763866_wp ! 0.000 0010  MHz T^-1
  real(wp), parameter :: shielded_proton_mag__mom_ = 1.410570499e-26_wp ! 0.000 000 035 e-26  J T^-1
  real(wp), parameter :: shielded_proton_mag__mom__to_Bohr_magneton_ratio = 1.520993128e-3_wp ! 0.000 000 017 e-3
  real(wp), parameter :: shielded_proton_mag__mom__to_nuclear_magneton_ratio = 2.792775598_wp ! 0.000 000 030
  real(wp), parameter :: speed_of_light_in_vacuum = 299792458e0_wp ! (exact)  m s^-1
  real(wp), parameter :: standard_acceleration_of_gravity = 9.80665_wp ! (exact)  m s^-2
  real(wp), parameter :: standard_atmosphere = 101325e0_wp ! (exact)  Pa
  real(wp), parameter :: standard_state_pressure = 100000e0_wp ! (exact)  Pa
  real(wp), parameter :: Stefan_Boltzmann_constant = 5.670373e-8_wp ! 0.000 021 e-8  W m^-2 K^-4
  real(wp), parameter :: tau_Compton_wavelength = 0.697787e-15_wp ! 0.000 063 e-15  m
  real(wp), parameter :: tau_Compton_wavelength_over_2_pi = 0.111056e-15_wp ! 0.000 010 e-15  m
  real(wp), parameter :: tau_electron_mass_ratio = 3477.15_wp ! 0.31
  real(wp), parameter :: tau_mass = 3.16747e-27_wp ! 0.000 29 e-27  kg
  real(wp), parameter :: tau_mass_energy_equivalent = 2.84678e-10_wp ! 0.000 26 e-10  J
  real(wp), parameter :: tau_mass_energy_equivalent_in_MeV = 1776.82_wp ! 0.16  MeV
  real(wp), parameter :: tau_mass_in_u = 1.90749_wp ! 0.000 17  u
  real(wp), parameter :: tau_molar_mass = 1.90749e-3_wp ! 0.000 17 e-3  kg mol^-1
  real(wp), parameter :: tau_muon_mass_ratio = 16.8167_wp ! 0.0015
  real(wp), parameter :: tau_neutron_mass_ratio = 1.89111_wp ! 0.000 17
  real(wp), parameter :: tau_proton_mass_ratio = 1.89372_wp ! 0.000 17
  real(wp), parameter :: Thomson_cross_section = 0.6652458734e-28_wp ! 0.000 000 0013 e-28  m^2
  real(wp), parameter :: triton_electron_mass_ratio = 5496.9215267_wp ! 0.000 0050
  real(wp), parameter :: triton_g_factor = 5.957924896_wp ! 0.000 000 076
  real(wp), parameter :: triton_mag__mom_ = 1.504609447e-26_wp ! 0.000 000 038 e-26  J T^-1
  real(wp), parameter :: triton_mag__mom__to_Bohr_magneton_ratio = 1.622393657e-3_wp ! 0.000 000 021 e-3
  real(wp), parameter :: triton_mag__mom__to_nuclear_magneton_ratio = 2.978962448_wp ! 0.000 000 038
  real(wp), parameter :: triton_mass = 5.00735630e-27_wp ! 0.000 000 22 e-27  kg
  real(wp), parameter :: triton_mass_energy_equivalent = 4.50038741e-10_wp ! 0.000 000 20 e-10  J
  real(wp), parameter :: triton_mass_energy_equivalent_in_MeV = 2808.921005_wp ! 0.000 062  MeV
  real(wp), parameter :: triton_mass_in_u = 3.0155007134_wp ! 0.000 000 0025  u
  real(wp), parameter :: triton_molar_mass = 3.0155007134e-3_wp ! 0.000 000 0025 e-3  kg mol^-1
  real(wp), parameter :: triton_proton_mass_ratio = 2.9937170308_wp ! 0.000 000 0025
  real(wp), parameter :: unified_atomic_mass_unit = 1.660538921e-27_wp ! 0.000 000 073 e-27  kg
  real(wp), parameter :: von_Klitzing_constant = 25812.8074434_wp ! 0.000 0084  ohm
  real(wp), parameter :: weak_mixing_angle = 0.2223_wp ! 0.0021
  real(wp), parameter :: Wien_frequency_displacement_law_constant = 5.8789254e10_wp ! 0.000 0053 e10  Hz K^-1
  real(wp), parameter :: Wien_wavelength_displacement_law_constant = 2.8977721e-3_wp ! 0.000 0026 e-3  m K
end module CODATA_2010_constants


text:
program main
  integer, parameter :: mykind = selected_real_kind()
  print *, 1
  print *, 1_mykind
  print *, 1.
  print *, 1._mykind
  print *, (1., 1._mykind)
end program main

max_stars_repo_name: btashton/pygments

max_issues_repo_name: btashton/pygments

max_forks_repo_name: btashton/pygments


text:
C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
*DECK,INTRPN
      SUBROUTINE INTRPN(ICONA,SOLNA,IELPT,STRPT,
     &                  SOLNB,NDLSTB,XB,YB,ZB,
     &                  IDBLK,TIMES,INSUB,SN)

C     ******************************************************************

C     SUBROUTINE TO CONTROL INTERPOLATION OF NODAL RESULTS FROM MESH-A
C     TO MESH-B
C     INTERPOLATED SOLUTION IS WRITTEN TO MESH-C EXODUS FILE

C     Calls subroutine SHAPEF, ININOD

C     Called by MAPVAR

C     ******************************************************************

C ICONA   INT   Connectivity of donor Mesh (1:nelnda,1:numeba)
C SOLNA   REAL  Nodal variables  for donor mesh
C IELPT   INT   The element in donor mesh within which the point
C               (node in recipient mesh) is found
C STRPT   REAL  The isoparametric coords of point in IELPT element
C SOLNB   REAL  Nodal variables for recipient mesh
C NDLSTB  INT   List of recipient mesh nodes in current element block
C SOLN    REAL  SOLNA vector local to each donor mesh element
C TIMES   REAL  Array of times - just passed through
C INSUB   INT   Number of times into subroutine for this element block
C               1-first time; >1-second,etc time;
C               used to control mapping for many element blocks to one

C     ******************************************************************

      include 'amesh.blk'
      include 'bmesh.blk'
      include 'aexds1.blk'
      include 'contrl.blk'
      include 'ebbyeb.blk'
      include 'ex2tp.blk'
      include 'steps.blk'
      include 'tapes.blk'
      include 'varnpt.blk'

      DIMENSION XB(*), YB(*), ZB(*), TIMES(*)
      DIMENSION ICONA(NELNDA,*), SOLNA(NODESA,NVARNP)
      DIMENSION SOLNB(NODESB,NVARNP), NDLSTB(*)
      DIMENSION IELPT(*), STRPT(3,NODESB)
      DIMENSION SOLN(27), SN(*)

C     ******************************************************************

C set up time steps

      IF (ISTEP .EQ. -1)THEN
        NTM = NTIMES
      ELSE
        NTM = 1
      END IF

      DO 5 IST = 1, NTM
        IF (ISTEP .EQ. -1)THEN
          ISTP = IST
        ELSE
          ISTP = ISTEP
        END IF

C Start interpolation

        DO 10 IVAR = 1, NVARNP

C For IDEF = 2 do mesh annealing (used by GOMA); write out all
C displacements as zero.

          IF (IDEF .EQ. 2 .AND. (IVAR .EQ. IXDIS .OR. IVAR .EQ. IYDIS
     &        .OR. IVAR .EQ. IZDIS))GO TO 10

C If first time into INTRPN for this element block, initialize
C else you are mapping many to one and retrieve partially mapped
C results from temporary storage in EXODUS

          IF (INSUB .EQ. 1)THEN
            CALL ININOD(SOLNB,IVAR,TIMES,ISTP,IDBLK,NDLSTB,XB,YB,ZB,
     &                  SN)
          ELSE
            CALL EXGNV(NTP4EX,IST,IVAR,NODESB,SOLNB(1,IVAR),IERR)
          END IF

C Get nodal results on donor mesh

          CALL EXGNV(NTP2EX,ISTP,IVAR,NODESA,SOLNA(1,IVAR),IERR)

C Loop on nodes in recipient mesh

          DO 30 I = 1,NUMNDB
            NEL = IELPT(I)
            IF (NEL .NE. 0) THEN

C Set parameters for element in donor mesh

              S = STRPT(1,I)
              T = STRPT(2,I)
              R = 0.
              IF (NDIMB.EQ.3) R = STRPT(3,I)
C              NNODES = NNELM(ITYPE)
              NNODES = NELNDA
              IF (ITYPE .EQ. 6) NNODES = 4
              DO 20 J = 1,NNODES
                INODE = ICONA(J,NEL)
                SOLN(J) = SOLNA(INODE,IVAR)
 20           CONTINUE

C Shape function

              CALL SHAPEF(ITYPE,S,T,R,SOLN,BVALUE)
              SOLNB(NDLSTB(I),IVAR) = BVALUE
            END IF
 30       CONTINUE

C Save results, it doesn't matter if they are preliminary or final

          CALL EXPNV(NTP4EX,IST,IVAR,NODESB,SOLNB(1,IVAR),IERR)

 10     CONTINUE
  5   CONTINUE

      RETURN
      END

max_stars_repo_name: jschueller/seacas

max_issues_repo_name: jschueller/seacas

max_forks_repo_name: jschueller/seacas


text:
 About us

Davis Swing Dancers is an established student organizations club on the UC Davis campus. We typically teach three swing lessons; one geared towards raw beginners that stays at a pretty constant skill level week to week and teaches the basic steps and fundamentals of East Coast Swing. One of our advanced lessons is usally a traditional East Coast variant, including Lindy Hop and Charleston, while the other is generally more West Coast and Blues oriented. Both of our two advanced lessons focus on connection, build on fundamentals, and explore more advanced variations. Each lesson is approximately an hour long and they happen simultaneously, running from 8:00 PM to 9:00 PM Monday nights. The beginning lesson is always free. Intermediate lessons are offered in a series format and are available for a nominal fee (just enough to provide compensation to the instructors).

The lesson is followed by social dancing, where you can get a first hand chance to practice everything you learn in the lesson, ask the teachers for advice, and simply have a blast dancing.
Taxi dancers were implemented Winter Quarter 2011.  Taxi dancers wear bright pieces of clothing and cannot refuse a dance. Dont be shy about asking them, its their job to dance with you.
Birthday jams will take place the last Monday of each month. A birthday jam is when we celebrate those of us who had birthdays in a particular month by having a circled dance with an exchange of partners multiple times during the song. No pressure, just fun!

Dancers of all levels are welcome, whether you are a world champion or have never danced before in your life.

Take everything you learn in the beginning lessons or somewhere else and make it flashy! Learn new moves that will dazzle!

Rooms and Lessons For the School Year:

We meet every Monday in Warren and Leta Giedt Hall Giedt Hall from 811PM while school is in session.

Lessons for this quarter:

Starting June 23rd:
Free Beginning Lessons in Everson 176 from 7:308:30
Free Social Dancing in Everson 176 from 8:3010:30

 About the teachers:

Our teachers are UC Davis Undergraduate Students, Graduate Students, Staff Members, or local dance teachers who want to spread their love for swing dancing to the Davis Community.

 Commonly Asked Questions:

What do I wear?
 Most people dress in casual comfortable clothes, and shoes that will stay on while dancing.  The rest do the second time.

Do I need to know how to dance?
 Not at all. If you show up to the lesson at the beginning, you will learn the basics to start you out. If you are interested in taking a series of lessons, we will have information at our meeting.

Do I need a partner?
 No again! The status quo is just show up and ask people to dance.

Do I need an invite to come?
 NO! Come dance. Even if you are convinced that you cant dance. We will still think that you are awesome. And we will teach you.

Are there other places to dance swing around here?
 Yes! To set up a safe and free carpool, contact dsdcarpool@gmail.com!
Carpools go to Firehouse 5, Midtown Stomp, The Station and more!

 Useful Links
Dance Calendar Dance Calendar
Dance Classes Dance Classes all sorts offered in Davis

 Contacts:

Official Email: davisswingdancers@gmail.com
Carpool Email: dsdcarpool@gmail.com

For more information about upcoming events or detailed lesson plans join the Facebook group Davis Swing Dancers.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
       program day06
        character*4 table(2, 10000), stack(10000), name
        integer n, i, p, depths(10000), d, dtot
c
c   Depth of me, santa, and common ancestor.
        integer dme, dsan, danc
        data n/1/, dme/-1/, dsan/-1/

c       Read each orbit
 1      read(*,*,end=2) (table(i, n), i=1,2)
        n = n + 1
        go to 1
 2      continue
c
c       Depth-first search to discover all the nodes
        stack(1) = 'COM'
        depths(1) = 0
        p = 1
        dtot = 0
c
c       While stack is not empty
 3      if (p.eq.0) go to 4
            name = stack(p)
            d = depths(p)
            p = p - 1
c
c           Sum total depths (equivalent to number of orbits)
            dtot = dtot + d
c
c           Find all the direct descendants of current node.
c           Unfortunate linear scan.
            do i = 1,n
                if (table(1, i).eq.name) then
                    p = p + 1
                    stack(p) = table(2, i)
                    depths(p) = d + 1
c
c                   Check for me or santa and remember the depth of each.
c                   After finding the first one, record the minimum depth of all
c                   subsequent nodes until the other is found. This gives the
c                   depth of the common ancestor.
                    if (table(2, i).eq.'YOU') then
                        dme = d
                        if (dsan.lt.0) danc = d
                    else if (table(2, i).eq.'SAN') then
                        dsan = d
                        if (dme.lt.0) danc = d
                    else if (dme.lt.0 .or. dsan.lt.0) then
                        danc = min(danc, d-1)
                    end if
                end if
            end do
        go to 3
c
c       Number of transfers is the sum of the differences in depth from me
c       and santa to the common ancestor.
 4      write(*,*) dtot, (dme - danc) + (dsan - danc)
        stop
       end program