*comdeck  cdkcbtz  convert blanks to zeroes in a word.
 btz      ctext  cdkcbtz - convert blanks to zeroes in a word.
 btz      space  4,10 
          if     -def,qual$,1 
          qual   cdkcbtz
          base   d
 btz      space  4,10 
***       btz - convert blanks to zeroes in a word. 
* 
*         g. m. townsend.    83/08/22.  code based on *comcztb*.
* 
*         btz converts all blanks in a word to 00 characters. 
 btz      space  4,10 
***       btz converts all blanks in a word to 00 characters. 
* 
*         entry  (x1) = word to be converted. 
*                (b1) = 1.
* 
*         exit   (x6) = converted word. 
*                (x7) = final character mask. 
* 
*         uses   x - 3, 6, 7. 
*                b - none.
*                a - 3. 
* 
*         calls  none.
  
  
 btz>     subr               entry/exit 
          sa3    btza 
          bx7    x1-x3       convert blanks to 00, others to misc 
          sa3    a3+b1
          bx6    x3*x7       remove upper bit from all characters 
          bx7    -x3*x7      isolate upper bits 
          ix6    x6+x3       any non-zero character produces carry
          bx6    x6+x7       merge upper bits and carries 
          bx7    -x3*x6      all non-zero characters = 40b
          bx6    x7 
          lx7    -5 
          ix7    x6-x7
          bx7    x6+x7       now have mask
          bx6    x7*x1       clear spaces from original word
          eq     btz>        and return 
  
 btza     con    10h
          con    37373737373737373737b
 btz      space  4,10 
          base   *
 qual$    if     -def,qual$ 
          qual   *
 btz>     equ    /cdkcbtz/btz>
 qual$    endif 
 btz      endx
*comdeck  cdkcmfs  move fortran string. 
 mfs      ctext  cdkcmfs - move fortran string. 
 mfs      space  4,10 
          if     -def,qual$,1 
          qual   cdkcmfs
          base   d
 mfs      space  4,10 
***       mfs - move fortran string.
* 
*         g. m. townsend.    83/05/31.
* 
*         mfs moves a (possibly unaligned) ftn5 character string
*         into a word-aligned buffer. 
 mfs      space  4,10 
***       mfs moves a ftn5 character string into a buffer.  this is 
*         particularly useful for subroutines which need their data 
*         word-aligned.  if the string is too long for the buffer, it 
*         is truncated;  if too short, it is padded with zeroes.
* 
*         mfs also works for ftn4 or ftn5 hollerith strings (characters 
*         stored in variables of other types);  since such strings
*         have no associated length they will be copied until the 
*         buffer is filled. 
* 
*         strings must be in cm (not ecs/lcm) and must not exceed 
*         777777b characters in length. 
* 
*         entry  (x1) = aplist entry specifying string in cm
*                            (see ftn5 reference manual) or address 
*                            of hollerith string. 
*                (b1) = 1.
*                (b6) = fwa of output buffer. 
*                (b7) = size of output buffer, in words.
* 
*         exit   (b6) = lwa+1 of buffer.
* 
*         uses   x - 1, 2, 6, 7.
*                b - 3, 4, 5, 6, 7. 
*                a - 2, 6.
* 
*         calls  none.
  
  
 mfs>     subr               entry/exit 
          sa2    x1          (a2/x2) = current input word 
          mx7    -6          (x7) = one-character mask
          ax1    24 
          bx6    -x1+x7      -(beginning char position) 
          ax1    6
          sb3    x1          (b3) = number of chars left (0 = unknown). 
          sb4    x6+10       (b4) = number of chars left in x2
          ix1    x6+x6       -2 * bcp 
          ix1    x6+x1       -3 * bcp 
          lx1    1           -6 * bcp (0 to -54)
          sb5    x1 
          ax2    b5          position x2 to first input character 
          mx6    0           (x6) = output word in progress 
          sb5    54          (b5) = shift count for stuffing output 
          nz     b3,mfs2     if input char count provided 
          sb3    -1          no, use huge count 
          eq     mfs2        join main loop 
  
 mfs1     sa2    a2+1        get next input word
          sb4    10          indicate 10 chars available
 mfs2     zr     b3,mfs4     if input string exhausted
          zr     b4,mfs1     if need to load new input word 
 mfs3     lx2    6           no, position to next character 
          sb3    b3-b1       count character from string
          bx1    -x7*x2      isolate it 
          sb4    b4-b1       count character from x2
          lx1    b5          position it
          sb5    b5-6        adjust shift count for next time 
          bx6    x6+x1       add into output word 
          pl     b5,mfs2     if output word not full
          sa6    b6          yes, save output word
          sb7    b7-b1       count it 
          sb6    b6+b1       bump store address 
          sb5    54          reset shift count
          mx6    0           clear output word
          gt     b7,mfs2     if output buffer not full
          eq     mfs>        if full, return
  
 mfs4     mx2    0           use zeroes for remaining characters
          sb4    b0          indicate huge number left
          eq     mfs3        rejoin loop
 mfs      space  4,10 
          base   *
 qual$    if     -def,qual$ 
          qual   *
 mfs>     equ    /cdkcmfs/mfs>
 qual$    endif 
 mfs      endx
*comdeck  cdkcmvc            move characters. 
 mvc      ctext  cdkcmvc - cm string move.
 mvc      space  4,10 
          if     -def,qual$,1 
          qual   cdkcmvc
          base   d
 mvc      space  4,10 
***       mvc - move character string.
* 
*         r. o. anderson, 
*         w. r. sears        75/05/21.
* 
*         r. o. anderson.    80/07/03.  handle char offsets .gt. 9. 
* 
*         mvc moves character strings.
 mvc      space  4,10 
***       mvc moves strings from one location to another on what
*         appears to be a character by character basis.  mvc does not 
*         change characters in the destination area that lie beyond the 
*         space covered by the string that was moved. 
* 
*         entry  (a1) = source address. 
*                (a2) = destination address.
*                (b1) = 1.
*                (b2) = source character offset (0 to 131071).
*                (b3) = destination character offset (0 to 131071). 
*                (b4) = number of characters to move (0 to 131071). 
* 
*         exit   string moved.
* 
*         uses   x - 1, 2, 3, 4, 5, 6, 7. 
*                b - 2, 3, 4, 5.
*                a - 1, 2, 3, 4, 6, 7.
  
  
 mvc.csiz equ    6           bits per character 
 mvc.cpw  equ    60/mvc.csiz characters per word
  
  
 mvc4     bx7    x2          set up 
          sa2    a2-b1       for first
          bx6    x2          iteration
          sa6    a2          of loop
 mvc5     bx5    -x3*x1      -123456789 
          bx2    x4*x7       abc------- 
          sa1    a1+b1       klmnopqrst 
          bx7    x3*x1       k--------- 
          bx7    x5+x7       k123456789 
          lx7    b2,x7       89k1234567 
          bx6    -x4*x7      ---1234567 
          bx6    x6+x2       abc1234567 
          sb4    b4-mvc.cpw  decrement characters left
          le     b4,mvc6     if done
          sa6    a6+b1       store this word
          eq     mvc5        loop till done 
  
 mvc6     sa2    mvca+mvc.cpw-1+b4  get proper edit mask
          sb3    b3-60       set up right circular shift of mask
          lx2    -b3,x2      ---******- 
          bx1    x4+x2       *********- 
          bx3    x4*x2       ---------- 
          bx7    x4*x7       890------- 
          sa2    a6+b1       abcdefghij 
          sa4    a2+b1       klmnopqrst 
          bx2    -x1*x2      ---------j 
          bx4    -x3*x4      klmnopqrst 
          bx6    x1*x6       abc123456- 
          bx7    x3*x7       ---------
          bx6    x6+x2       abc123456j 
          bx7    x7+x4       klmnopqrst 
          sa6    a2          update 
          sa7    a4          last words 
 mvc>     subr               entry/exit 
          le     b4,mvc>     quit if nothing to do
          sx6    mvc.csiz    x6 = bits per character
 mvc0     sb2    b2-10       compute source word address
          mi     b2,mvc0a    if word address ok 
          sa1    a1+b1       advance 1 word 
          eq     mvc0 
  
 mvc0a    sb2    b2+10       compute corrected source offset
          mx5    1           for mask generation
          sb5    b2          save source offset for later 
 mvc0b    sb3    b3-10       compute destination word address 
          mi     b3,mvc0c    if word address ok 
          sa2    a2+b1       advance 1 word 
          eq     mvc0b
  
 mvc0c    sb3    b3+10       compute corrected destination offset 
          sx7    b2          convert
          ix7    x7*x6       source offset
          sb2    x7          to bits
          sx7    b3          convert
          ix7    x7*x6       destination offset 
          sb3    x7          to bits
          ax3    x5,b2       build source and 
          ax4    x5,b3       destination masks
          lx5    b1,x3       compensate 
          bx3    x5*x3       for
          lx5    b1,x4       extra
          bx4    x5*x4       bit
          sx6    a1          get fwa of source area 
          sb2    b2-b3       b2 is offset difference
          pl     b2,mvc1     skip if positive 
          sb2    b2+60       else make it positive
 mvc1     sx7    a2          get destination fwa
          ix5    x6-x7       see if fwa source .ge. fwa dest. 
          pl     x5,mvc4     if so
          sx5    b5+b4       get character offset of lwa source 
          sx7    mvc.cpw     compute
          mx6    -1          characters per word
          ix6    x6+x7       minus one
          ix5    x5+x6       x5 = offset + rounding value 
*          ix7    x5/x7,b5    word offset of lwa + 1 source 
          ix7    x5/x7       word offset of lwa + 1 source
          sx6    a1          compute lwa + 1
          ix5    x6+x7       of source
          sx6    a2          see if lwa + 1 source
          ix6    x6-x5       .le. fwa destination 
          pl     x6,mvc4     if so
          sa1    x5-1        a1 = lwa source
          sx6    a2          compute
          ix5    x6+x7       lwa + 1 destination
          sa2    x5-1        a2 = lwa destination 
          sx7    mvc.cpw     compute
          sx6    b4          remainder of 
          px6    x6,b0         integer divide 
          px7    x7,b0
          nx7    x7,b0
          fx5    x6/x7
          ux6,b5 x6          restore registers
          lx6    x6,b5
          ux7,b5 x7 
          lx7    x7,b5
          ux5,b5 x5 
          lx5    x5,b5
          ix5    x5*x7       number of characters / chars per word
          ix5    x6-x5       then get 
          ix5    x5-x7       index into mask table
          sb5    mvca+mvc.cpw-1+x5  b5 = pointer to mask
          bx6    x3          save 
          sa6    mvcb        both 
          bx7    x4          masks
          sa7    a6+b1       for later
          lx6    x1,b2       ^!+"*/[]() 
          bx5    x4*x6       ^!+------- 
          bx6    x3*x1       +--------- 
          sa1    a1-b1       0123456789 
          bx1    -x3*x1      -123456789 
          bx6    x6+x1       +123456789 
          lx7    x6,b2       89+1234567 
          bx6    x4*x7       89+------- 
          sa1    a1+b1       +"*/[]()^! 
          lx1    x1,b2       ^!+"*/[]() 
          bx1    -x4*x1      ---"*/[]() 
          bx6    x6+x1       89+"*/[]() 
          sa3    b5          get the edit mask
          sb5    b3-60       get mask rotation value
          lx3    -b5,x3      **-******* 
          bx1    x4+x3       ********** 
          bx3    x4*x3       **-------- 
          sa4    a2+b1       %%%%%%%%%% 
          bx4    -x3*x4      --%%%%%%%% 
          bx5    x3*x5       ^!-------- 
          bx5    x5+x4       ^!%%%%%%%% 
          bx2    -x1*x2      ---------- 
          bx4    x1*x6       89+"*/[]() 
          bx6    x5          ^!%%%%%%%% 
          sa6    a4          update last word in dest. area 
          bx6    x4+x2       89+"*/[]() 
          sa6    a2          update the next to last word 
          cx1    x1          see
          cx3    x3          how many 
          ix3    x3+x1       characters 
          sx1    mvc.csiz    were 
*          ix3    x3/x1,b5    used
          ix3    x3/x1       used 
          sb5    x3          and decrement
          sb4    b4-b5       the total
          le     b4,mvc>     if done
          sa1    a1-b1       0123456789 
          sa3    mvcb        recover
          sa4    a3+b1       masks
 mvc2     bx5    x3*x1       0--------- 
          bx2    -x4*x7      ---1234567 
          sa1    a1-b1       abcdefghij 
          bx7    -x3*x1      -bcdefghij 
          bx7    x7+x5       0bcdefghij 
          lx7    b2,x7       ij0bcdefgh 
          bx6    x4*x7       ij0------- 
          bx6    x6+x2       ij01234567 
          sb4    b4-mvc.cpw  decrement characters left
          le     b4,mvc3     if done
          sa6    a6-b1       store this word
          eq     mvc2        loop till done 
  
 mvc3     bx6    -x4*x6      ---bcdefgh 
          sa1    a6-b1       klmnopqrst 
          bx1    x4*x1       klm------- 
          bx6    x1+x6       klmbcdefgh 
          sa6    a1          store last word
          eq     mvc>        return 
  
 mvca     vfd    mvc.csiz/-0,*p/0  mask table 
 .mvcif   ifgt   mvc.cpw,2
 .mvcset  set    mvc.csiz 
 .mvc1up  dup    mvc.cpw-2
 .mvcset  set    .mvcset+mvc.csiz 
          vfd    .mvcset/-0,*p/0
 .mvc1up  endd
 .mvcif   endif 
          data   -0 
  
 mvcb     bss    2           to save masks
 mvc      space  4,10 
          base   *
 qual$    if     -def,qual$ 
          qual   *
 mvc>     equ    /cdkcmvc/mvc>
 qual$    endif 
 mvc      endx
*comdeck  cdkcscs  select character set.
 scs      ctext  cdkcscs - select character set.
 scs      space  4,10 
          if     -def,qual$,1 
          qual   cdkcscs
          base   d
 scs      space  4,10 
***       scs - select character set. 
* 
*         g. m. townsend.    81/02/17.
* 
*         scs determines the character set of a file by inspecting the
*         first buffer full of data.
 scs      space  4,10 
***       scs looks at a portion of a file to determine whether it is 
*         display code or 7-in-12 ascii.  it does this by seeing if 
*         there are zero bits where they should be for an ascii file; 
*         if not, the file is assumed to be in display code.  the 
*         algorithm is not foolproof -- it can falsely diagnose a file
*         as ascii if it contains only the display code characters
*         a, 5, and 6 (also *:* in 64-character set) in odd-numbered
*         columns.  despite this, the method works well in practice.
* 
*         scs looks at all the data in a circular buffer, as indicated
*         by the fet.  the caller should first issue a read, then call
*         scs.
* 
*         entry  (x2) = fet address.
*                (b1) = 1.
* 
*         exit   (x6) = 1 if display code.
*                (x6) = 0 if buffer is empty. 
*                (x6) = -1 if nos 812 ascii.
*                (x6) = -2 if ut 812 ascii. 
* 
*         uses   x - 1, 3, 6. 
*                b - 2, 3, 4, 5.
*                a - 1, 3.
  
  
 scs>     subr               entry/exit 
          recall x2          wait for read to finish
          sa1    x2+b1
          sb2    x1          (b2) = first 
          sa1    a1+b1
          sb3    x1          (b3) = in
          sa1    a1+b1
          sb4    x1          (b4) = out 
          sa1    a1+b1
          sb5    x1          (b5) = limit 
          sx6    b0 
          eq     b3,b4,scs>  if empty buffer, return
          sa3    scsa        (x3) = mask
          sx6    b1          assume display code
 scs1     sa1    b4          fetch word 
          bx1    -x3*x1 
          zr     x1,scs2     if ok ascii so far, check more 
          sa1      b4              check against ut 812 ascii 
          sa3      scsb 
          bx1      -x3*x1 
          nz       x1,scs>         if display code, return
scs2      sb4      b4+b1           bump pointer 
          eq     b4,b3,scs3  if no more in buffer 
          lt     b4,b5,scs1  if not yet to limit
          sb4    b2          go back to first 
          ne     b4,b3,scs1  if more to check 
 scs3     sx6    -b1         indicate ascii 
          sa1      scsa 
          bx1      x1-x3
          zr       x1,scs>         if nos 812 ascii 
          sx6      -2              indicate ut 812 ascii
          eq     scs>        return 
  
scsa      data   41774177417741774177b  mask for bits in ascii chars
scsb      data   43774377437743774377b  mask for ut 812 chars 
 scs      space  4,10 
          base   *
 qual$    if     -def,qual$ 
          qual   *
 scs>     equ    /cdkcscs/scs>
 qual$    endif 
 scs      endx
*comdeck  cdkcsxt            convert characters, sixbit to twelvebit. 
 sxt      ctext  cdkcsxt - sixbit to twelve bit character mapping.
 sxt      space  4,10 
          if     -def,qual$,1 
          qual   cdkcsxt
          base   d
 sxt      space  4,10 
***       sxt - sixbit to twelve bit character mapping. 
* 
*         r. o. anderson.    75/01/27.
* 
*         sxt converts a 6-bit character set into a 12-bit character
*         set.
 sxt      space  4,10 
***       sxt performs a character mapping operation using a conversion 
*         table of 1 character per word, right justified, binary zero 
*         filled.  the table is assumed to be long enough to allow
*         mapping of any character encountered in the input string. 
* 
*         entry  (b1) = 1.
*                (b2) = address of input string.
*                (b3) = length of input string, in words. 
*                (b4) = address of output string. 
*                (b5) = address of conversion table.
* 
*         exit   string converted.
* 
*         uses   x - 1, 2, 6, 7.
*                b - none.
*                a - 1, 2, 6. 
  
  
  
 sxt>     subr               entry/exit 
          sx6    b3          save input 
          sa6    sxta        string length
          sx6    b4          save output
          sa6    a6+b1       start address
          sb3    b2+b3       compute lwa + 1 of input area
          mx7    -6          set up a one byte mask 
 sxt1     sa1    b2          read up the next word to convert 
          mx6    0           clear assembly register
 .sxt     dup    5
          lx1    6           get one character
          bx2    -x7*x1      in x2
          sa2    b5+x2       get replacement
          lx6    12          make room for new character
          bx6    x6+x2       add in new character 
 .sxt     endd
          sa6    b4          store output word
          mx6    0           clear assembly register
 .sxt     dup    5
          lx1    6           get one character
          bx2    -x7*x1      in x2
          sa2    b5+x2       get replacement
          lx6    12          make room for new character
          bx6    x6+x2       add in new character 
 .sxt     endd
          sa6    a6+b1       store output word
          sb2    b2+b1       increment in pointer 
          sb4    a6+b1       increment out pointer
          lt     b2,b3,sxt1  loop till done 
          sa1    sxta        recover input
          sb3    x1          string length
          sa1    a1+b1       recover output 
          sb4    x1          start address
          sb2    b2-b3       restore input starting address 
          eq     sxt>        return 
  
 sxta     bss    2           to save length and out start addr
 sxt      space  4,10 
          base   *
 qual$    if     -def,qual$ 
          qual   *
 sxt>     equ    /cdkcsxt/sxt>
 qual$    endif 
 sxt      endx
*comdeck  cdkctxs            convert characters, twelvebit to sixbit. 
 txs      ctext  cdkctxs - twelve bit to sixbit character mapping.
 txs      space  4,10 
          if     -def,qual$,1 
          qual   cdkctxs
          base   d
 txs      space  4,10 
***       txs - twelve bit to sixbit character mapping. 
* 
*         r. o. anderson.    75/01/27.
* 
*         txs converts a 12-bit character set into a 6-bit character
*         set.
 txs      space  4,10 
***       txs performs a character mapping operation using a conversion 
*         table of 1 character per word, right justified, binary zero 
*         filled.  the table is assumed to be long enough to allow
*         mapping of any character encountered in the input string. 
* 
*         entry  (b1) = 1.
*                (b2) = address of input string.
*                (b3) = length of input string, in words. 
*                (b4) = address of output string. 
*                (b5) = address of conversion table.
* 
*         exit   string converted.
* 
*         uses   x - 1, 2, 6, 7.
*                b - none.
*                a - 1, 2, 6. 
  
  
  
 txs>     subr               entry/exit 
          sx6    b3          save input 
          sa6    txsa        string length
          sx6    b4          save output
          sa6    a6+b1       start address
          sb3    b2+b3       compute lwa + 1 of input area
          mx7    -12         set up a one byte mask 
 txs1     sa1    b2          read up the next word to convert 
          mx6    0           clear assembly register
 .txs     dup    5
          lx1    12          get one character
          bx2    -x7*x1      in x2
          sa2    b5+x2       get replacement
          lx6    6           make room for new character
          bx6    x6+x2       add in new character 
 .txs     endd
          sb2    b2+b1       increment in pointer 
          ge     b2,b3,txs3  store word if input length odd 
          sa1    b2          else get next word and continue
 .txs     dup    5
          lx1    12          get one character
          bx2    -x7*x1      in x2
          sa2    b5+x2       get replacement
          lx6    6           make room for new character
          bx6    x6+x2       add in new character 
 .txs     endd
          sa6    b4          store output word
          sb2    b2+b1       increment in pointer 
          sb4    b4+b1       increment out pointer
          lt     b2,b3,txs1  loop till done 
 txs2     sa1    txsa        recover input
          sb3    x1          string length
          sa1    a1+b1       recover output 
          sb4    x1          start address
          sb2    b2-b3       restore input starting address 
          eq     txs>        return 
  
 txs3     lx6    30          position partial word
          sa6    b4          save it
          eq     txs2        to complete exit 
  
 txsa     bss    2           to save length and out start addr
 txs      space  4,10 
          base   *
 qual$    if     -def,qual$ 
          qual   *
 txs>     equ    /cdkctxs/txs>
 qual$    endif 
 txs      endx
*comdeck  cdkcvfn            validate file name.
 vfn      ctext  cdkcvfn - validate file name.
 vfn      space  4,10 
          if     -def,qual$,1 
          qual   cdkcvfn
          base   d
 vfn      space  4,10 
***       vfn - validate file name. 
* 
*         g. m. townsend.    78/02/02.
* 
*         vfn checks that a string is a legal file name.
 vfn      space  4,10 
***       entry  (x1) = file name, l format.
*                (b1) = 1.
* 
*         exit   (x1) = 0 if legal. 
* 
*         uses   x - 1, 2, 6. 
*                b - 2. 
*                a - none.
  
  
 vfn>     subr               entry/exit 
          mi     x1,vfn>     if negative, return immediately
          bx2    x1 
          ax2    54 
          sx2    x2-1r0 
          pl     x2,vfn>     if first char numeric, return
          sb2    7           (b2) = character counter 
          mx2    -6          (x2) = character mask
 vfn1     lx1    6
          bx6    -x2*x1      (x6) = character 
          zr     x6,vfn>     if zero character, return
          sx6    x6-1r9-1 
          pl     x6,vfn>     if illegal character, return 
          bx1    x2*x1       clear out last char, it is legal 
          sb2    b2-b1
          nz     b2,vfn1     if more characters to test 
          eq     vfn>        return 
 vfn      space  4,10 
          base   *
 qual$    if     -def,qual$ 
          qual   *
 vfn>     equ    /cdkcvfn/vfn>
 qual$    endif 
 vfn      endx
*deck rel 
          ident  cpu.btz
          entry  btz> 
 btz      title  btz - convert blanks to zeroes in a word.
          comment convert blanks to zeroes in a word. 
*call     cdkcbtz 
          end 
          ident  cpu.mfs
          entry  mfs> 
 mfs      title  mfs - move fortran string. 
          comment move fortran string.
*call     cdkcmfs 
          end 
          ident  cpu.mvc
          entry  mvc> 
 mvc      title  mvc - move characters. 
          comment move characters.
*call     cdkcmvc 
          end 
          ident  cpu.scs
          entry  scs> 
 scs      title  scs - select character set.
          comment select character set. 
*call     cdkcscs 
          end 
          ident  cpu.sxt
          entry  sxt> 
 sxt      title  sxt - convert characters, sixbit to twelvebit. 
          comment convert characters, sixbit to twelvebit.
*call     cdkcsxt 
          end 
          ident  cpu.txs
          entry  txs> 
 txs      title  txs - convert characters, twelvebit to sixbit. 
          comment convert characters, twelvebit to sixbit.
*call     cdkctxs 
          end 
          ident  cpu.vfn
          entry  vfn> 
          sst 
 vfn      title  vfn - validate file name.
          comment validate file name. 
*call     cdkcvfn 
          end 
*deck macrel
          ident  macrel 
          entry    macrel.,macrel=,macwal=
          sst 
          b1=1
          list   f
          title  macrel - system macro interface routines.
          comment  system macro interface routines. 
 macrel   space  4,10 
***       macrel - system macro interface routines. 
* 
*         t. r. ramsey.      76/08/08.
* 
*         copyright control data corporation. 1976. 
 macrel   space  4,10 
***              macrel is a collection of relocatable modules that 
*         provide the interface between higher level language modules 
*         and the system macros.
* 
*         fortran calling sequences are shown in each module along with 
*         other pertinent information, e.g., entry, exit. 
          title  macrel - system macro interface routines.
 macrel   space  4,10 
**               macrel modules translate parameters in higher level
*         language calling sequences into macro calling sequences.
*         fortran calling sequences mentioned are equivalent to 
*         cobol (enter using), sympl, etc.
* 
*         entry  fortran *call* and function reference calling
*                sequences use the actual parameter list, call by 
*                reference calling sequence where - 
*                 (a1)      = fwa of aplist 
*                ((a1))     # first parameter 
*                ((a1+1))   # second parameter
*                  .          . 
*                  .          . 
*                  .          . 
*                ((a1+n))   # n-th parameter
*                ((a1+n+1)) = 0 (zero)  (nominally)  (un-needed herein) 
*                 (x1)      # first parameter 
* 
*         exit   for *call*, typically none, but see individual modules.
*                for function references, 
*                (x6) = function result 
*                (x7) = second word of two word result, e.g., complex 
* 
*         uses   preserves a0 
* 
*         calls  macrel. if macro undefined or not coded yet
*                macrel= if argument error
* 
*         needs  each module contains a call to a macro whose name is 
*                the same as the module (except where noted).  these
*                macros are defined in systext (kronos nos) and cputext 
*                (scope nos/be) and also in jettext.  jettext is the
*                preferred system text. 
* 
*         note   b1 is set to one upon entry to each module 
* 
*         other  macrel is a collection of relocatable modules combined 
*                into one *update* deck entity named macrel.  the 
*                modules are arranged in the same order as the macros 
*                in jettext.
 macrel.  space  4,10 
**        macrel. - undefined macro processor.
* 
*         entry  (x1) = macro name in 0l format 
* 
*         exit   does not exit
* 
*         uses   a6  b1  x6 
* 
*         calls  none 
* 
*         needs  macros abort, message
  
  
 macrel.  subr               entry/exit 
          sb1    1
          bx6    x1 
          sa6    maca+3 
          message  maca,,rcl
          abort 
          eq       macrel.
  
 maca     data   c* macrel - undefined macro -   fill-in.*
 macrel=  space  4,10 
**        macrel= - illegal argument processor. 
* 
*         entry  (x1) = macro name in 0l format 
*                (x2) = illegal argument
* 
*         exit   does not exit
* 
*         uses   a6  b1  x0,x1,x2,x6
* 
*         calls  ztb= 
* 
*         needs  macros abort, message
  
  
 macrel=  subr               entry/exit 
          sb1    1
          bx0    x2          save second argument 
          lx1    -6 
          sx2    1r-
          bx1    x1+x2
          rj     =xztb= 
          bx1    x0 
          sa6    macb 
          rj     =xztb= 
          sa6    macb+3 
          message  macb,,rcl
          abort  ,nd
          eq       macrel=
  
 macb     data   c* fill-in - illegal argument  >fill-it-in<.*
 macwal=  space  4,10 
**        macwal= - word align a 10 or less character parameter.
* 
*         entry  (x1) = ftn/ftn5 argument list item.
* 
*         exit   (x2) = value from argument list, left justified, with
*                space fill, unless value was 0b or all spaces, in
*                which case, 0b returned. 
* 
*         uses   a2,a3,a6  b1,b3,b4,b5,b6,b7  x1,x2,x3,x6,x7
* 
*         calls  mfs>, ztb=.
  
  
 macwal=  subr               entry/exit 
          sb1    1
          sb6    macc        where mfs can stash the result 
          sb7    b1          length of mfs buffer 
          rj     =xmfs>      move the option
          sa2    macc        get the result 
          zr     x2,macwal=  if nothing specified, return binary zero 
          bx1    x2          for ztb
          rj     =xztb=      blank out the 00b characters 
          sa2    macd        spaces 
          bx2    x2-x6
          zr     x2,macwal=  map spaces to zero for ftn5
          bx2    x6          for most of our callers, this is best
          eq     macwal=     return 
  
 macc     bss    1           buffer for mfs 
 macd     data   10h
  
          end 
          ident  excst
          entry  excst
          sst 
          syscom b1 
 excst    title  excst - execute control statement for ftn. 
          comment (ftn) execute control statement.
 excst    space  4,10 
*****     excst - execute control statement for ftn.
* 
*         r. o. anderson.    83/10/31.
* 
*         allow ftn program to execute a control statement. 
 excst    space  4,10 
***       excst allows an ftn program to execute a control
*         statement at termination. 
* 
*         call excst(string)
* 
*         entry  *string* is a hollerith string (ftn4), including 
*                a line terminator, or a character variable (ftn5). 
*                in either case, the maximum length is 80 characters. 
* 
*         exit   does not return. 
* 
*         calls  mfs>, sys=.
  
  
 excst    subr     =               entry (only) 
          sb1      1               always 
          sb6      ccdr            where to put the image 
          sb7      8               maximum buffer length
          rj       =xmfs>          move the string
          excst    ccdr            execute image
*         system   pcc,r,ccdr      execute image (does not return)
          endrun                   in case we did a 1aj command 
  
          end 
          ident  close
          entry    close
          sst 
          b1=1
          title  close - close file.
          comment   close file. 
 close    space  4,10 
***       close - close file. 
* 
*         call close (file,option)
* 
*         entry  (file) = first word of the fet 
*                (option) = a hollerith string or character variable
*                           with any of the following values. 
*                         = 0 or blanks, close with rewind
*                         = ^nr^, close without rewind
*                         = ^reel^, close reel with rewind
*                         = ^reelnr^, close reel without rewind 
*                         = ^reelun^, close reel with rewind, unload
*                         = ^return^, close with rewind, return 
*                         = ^rewind^, close with rewind 
*                         = ^unload^, close with rewind, unload 
* 
*         exit   to argument-error processor if option is unrecognized
*         else   none 
  
  
 close    subr
          sb1    1
          sa1    a1+b1       point to option
          rj     =xmacwal=   word align option
          sa1    a1-b1       reset x1 to be fet address 
          zr,x2  clo1 
          sa3    =0hnr
          bx4    x2-x3
          zr,x4  clo2        if nr
          sa3    =0hreel
          bx4    x2-x3
          zr,x4  clo3        if reel
          sa3    =0hreelnr
          bx4    x2-x3
          zr,x4  clo4        if reelnr
          sa3    =0hreelun
          bx4    x2-x3
          zr,x4  clo5        if reelun
          sa3    =0hreturn
          bx4    x2-x3
          zr,x4  clo6        if return
          sa3    =0hrewind
          bx4    x2-x3
          zr,x4  clo7        if rewind
          sa3    =0hunload
          bx4    x2-x3
          zr,x4  clo8        if unload
          sa1    =0lclose 
          rj     =xmacrel=   diagnose illegal argument
          eq     close
  
 clo1     close  x1 
          eq     close
  
 clo2     close  x1,nr
          eq     close
  
 clo3     closer x1 
          eq     close
  
 clo4     closer x1,nr
          eq     close
  
 clo5     closer x1,unload
          eq     close
  
 clo6     close  x1,return
          eq     close
  
 clo7     close  x1 
          eq     close
  
 clo8     close  x1,unload
          eq     close
  
          end 
          ident  open 
          entry  open 
          sst 
          b1=1
          title  open - open file for processing. 
          comment   open file for processing. 
 open     space  4,10 
***       open - open file for processing.
* 
*         call open (file,option) 
* 
*         entry  (file) = first word of the fet 
*                (option) = a hollerith string or character variable
*                           with any of the following values. 
*                         = 0 or blanks, same as ^alter^
*                         = ^alter^, open with rewind for i-o 
*                         = ^alternr^, open for i-o 
*                         = ^nr^, open
*                         = ^read^, open with rewind for input
*                         = ^readnr^, open for input
*                         = ^reel^, open reel with rewind 
*                         = ^reelnr^, open reel 
*                         = ^write^, open with rewind for output
*                         = ^writenr^, open for output
* 
*         exit   to argument-error processor if option is unrecognized
*         else   none 
  
  
 open     subr
          sb1    1
          sa1    a1+b1       point to option
          rj     =xmacwal=   word align option
          sa1    a1-b1       reset x1 to be fet address 
          zr,x2  ope1 
          sa3    =0halter 
          sa4    =0halternr 
          sa5    =0hnr
          bx3    x2-x3
          bx4    x2-x4
          zr,x3  ope2        if alter 
          bx5    x2-x5
          zr,x4  ope3        if alternr 
          zr,x5  ope4        if nr
          sa3    =0hread
          sa4    =0hreadnr
          sa5    =0hreel
          bx3    x2-x3
          bx4    x2-x4
          zr,x3  ope5        if read
          bx5    x2-x5
          zr,x4  ope6        if readnr
          zr,x5  ope7        if reel
          sa3    =0hreelnr
          sa4    =0hwrite 
          sa5    =0hwritenr 
          bx3    x2-x3
          bx4    x2-x4
          zr,x3  ope8        if reelnr
          bx5    x2-x5
          zr,x4  ope9        if write 
          zr,x5  ope10       if writenr 
          sa1    =0lopen
          rj     =xmacrel=   diagnose illegal argument
          eq     open 
  
 ope1     open   x1 
          eq     open 
  
 ope2     open   x1,alter 
          eq     open 
  
 ope3     open   x1,alternr 
          eq     open 
  
 ope4     open   x1,nr
          eq     open 
  
 ope5     open   x1,read
          eq     open 
  
 ope6     open   x1,readnr
          eq     open 
  
 ope7     open   x1,reel
          eq     open 
  
 ope8     open   x1,reelnr
          eq     open 
  
 ope9     open   x1,write 
          eq     open 
  
 ope10    open   x1,writenr 
          eq     open 
  
          end 
          ident  read 
          entry  read 
          sst 
          b1=1
          title  read - read file to cio buffer.
          comment   read file to cio buffer.
 read     space  4,10 
***       read - read file to cio buffer. 
* 
*         call read (file)
* 
*         entry  (file) = first word of the fet 
  
  
 read     subr
          sb1    1
          read   x1 
          eq     read 
  
          end 
          ident  writer 
          entry  writer 
          sst 
          b1=1
          title  writer - write end of record.
          comment   write end of record.
 writer   space  4,10 
***       writer - write end of record. 
* 
*         call writer (file,level)
* 
*         entry  (file) = first word of the fet 
*                (level) = record level 
  
  
 writer   subr
          sb1    1
          sa3    a1+b1       address of level 
          sa3    x3          level
          writer x1,x3
          eq     writer 
  
          end 
          ident  readc
          entry  readc
          sst 
          b1=1
          title  readc - read coded line in *c* format. 
          comment   read coded line in *c* format.
 readc    space  4,10 
***       readc - read coded line in *c* format.
* 
*         call readc (file,buf,n,status)
* 
*         transfers data until the end of line byte (0000) is sensed. 
* 
*         entry  (file) = first word of the fet 
*                (buf) = first word of the working buffer 
*                (n) = word count of the working buffer 
* 
*         exit   (status) = 0, transfer complete
*                         = -1, end-of-file detected on file
*                         = -2, end-of-information detected on file 
*                         = lwa, end-of-record detected on file before
*                                transfer was complete
*                     lwa = address + 1 of last word transferred to 
*                           working buffer
  
  
 readc    subr
          sb1    1
          sa3    a1+b1       fwa of working buffer
          sa4    a3+b1       address of word count
          sa5    a4+b1       (x5) = address of status word
          bx6      x5 
          sa4    x4          word count 
          readc  x1,x3,x4 
          bx6    x1 
          sa6    x5 
          eq     readc
  
          end 
          ident  readw
          entry  readw
          sst 
          b1=1
          title  readw - read data to working buffer. 
          comment   read data to working buffer.
 readw    space  4,10 
***       readw - read data to working buffer.
* 
*         call readw (file,buf,n,status)
* 
*         entry  (file) = first word of the fet 
*                (buf) = first word of the working buffer 
*                (n) = word count of the working buffer 
* 
*         exit   (status) = 0, transfer complete
*                         = -1, end-of-file detected on file
*                         = -2, end-of-information detected on file 
*                         = lwa, end-of-record detected on file before
*                                transfer was complete
*                     lwa = address + 1 of last word transferred to 
*                           working buffer
  
  
 readw    subr
          sb1    1
          sa3    a1+b1       fwa of working buffer
          sa4    a3+b1       address of word count
          sa5    a4+b1       (x5) = address of status word
          sa4    x4          word count 
          readw  x1,x3,x4 
          bx6    x1 
          sa6    x5 
          eq     readw
  
          end 
          ident  writew 
          entry  writew 
          sst 
          b1=1
          title  writew - write data from working buffer. 
          comment   write data from working buffer. 
 writew   space  4,10 
***       writew - write data from working buffer.
* 
*         call writew (file,buf,n)
* 
*         entry  (file) = first word of the fet 
*                (buf) = first word of the working buffer 
*                (n) = word count of the working buffer 
  
  
 writew   subr
          sb1    1
          sa3    a1+b1       fwa of working buffer
          sa4    a3+b1       address of word count
          sa4    x4          word count 
          writew x1,x3,x4 
          eq     writew 
  
          end 
          ident  mtr
          entry  mtr
          sst 
          b1=1
 mtr      title  mtr - issue monitor calls from ftn.
          comment      issue monitor calls from ftn.
 mtr      space  4,10 
*****     mtr - issue monitor calls from ftn. 
* 
*         b. l. trumbo.     78-aug-31 
* 
*         mtr allows monitor calls to be issued from an ftn program,
*         either as a 60-bit request, or in the same format as
*         the *system* macro. 
 mtr      space  4,10 
***       mtr - issue monitor calls from ftn. 
* 
*         call mtr (ppcall) 
*         call mtr (ppname,recall)
*         call mtr (ppname,recall,arg)
*         call mtr (ppname,recall,arg1,arg2)
* 
*         entry  *ppcall* is a 60-bit (integer) quantity, and is
*                  issued as a monitor call without modification. 
*                *ppname* is the name of the pp routine to be called, 
*                  left justified.  only the upper 18 bits are used.
*                *recall* is either zero or non-zero.  if it is zero, 
*                  no recall bit is inserted. 
*                *arg* is an argument to be passed to the pp routine
*                  called.  the lower 36 bits are passed as the lower 
*                  36 bits of the ra+1 call.
*                *arg1* is an argument to be passed to the pp routine 
*                  called.  the lower 18 bits are passed as the lower 
*                  18 bits of the ra+1 call.
*                *arg2* is an argument to be passed to the pp routine 
*                  called.  the lower 18 bits are passed as bits 18 
*                  thru 35 of the ra+1 call.
* 
*         exit   all input arguments preserved, monitor call issued.
*                if recall bit was set in call, ra+1 will be clear. 
* 
*         uses   a1,a2,a3,a4,   a6
*                b1 
*                x1,x2,x3,x4,   x6,x7 
* 
*         calls  sys=.
 mtr      space  4,10 
 mtr2     bx4    -x6*x4      strip *arg* to 36 bits, assuming no *arg2* 
          lx3    40d         position recall bit
          bx2    x2+x4       combine pp name and arg(s) 
          bx2    x2+x3       or in recall bit 
 mtr1     bx6    x2 
          system             issue the monitor call in x6 
  
 mtr      subr   =           entry/exit 
          sb1    1           11th commandment 
          sa2    x1          pick up pp name
          sa1    a1+b1       pick up address of *recall* arg
          zr     x1,mtr1     if only one arg, issue it as is
          mx7    18 
          sa3    x1          pick up *recall* arg 
          mx4    0           assume zero *arg*
          cx3    x3          convert *recall* to a bit
          sa1    a1+b1       pick up address of *arg* 
          cx3    x3 
          bx2    x7*x2       strip pp name down to 3 chars
          cx3    x3 
          mx6    -36d        mask for use at mtr2 
          cx3    x3          now have only one recall bit 
          zr     x1,mtr2     if no *arg* supplied, use zero 
          sa4    x1          if *arg* supplied, use it
          sa1    a1+b1       pick up address of *arg2*
          zr     x1,mtr2     if no *arg2* 
          sa1    x1 
          mx7    -18d 
          bx4    -x7*x4      strip *arg1* down to 18 bits 
          bx1    -x7*x1      strip *arg2* down to 18 bits 
          lx1    18d
          bx4    x4+x1       x4 contains composite arg
          eq     mtr2 
  
          end 
          ident  endrun 
          entry    endrun 
          sst 
          b1=1
          list   f
          title  endrun - end central program.
          comment   endrun. 
 endrun   space  4,10 
***       endrun - end central program. 
* 
*         call endrun 
* 
*         entry  none 
* 
*         exit   does not exit
  
  
 endrun   subr
          sb1    1
          endrun
  
          end 
          ident  recall 
          entry  recall 
          sst 
          b1=1
          list   f
          title  recall - place program in recall status. 
          comment   place program in recall status. 
 recall   space  4,10 
***       recall - place program in recall status.
* 
*         call recall (status)
* 
*         entry  (status) = 0, one system periodic recall is issued 
*                         = other, program is recalled when bit 0 is set
* 
*         exit   none if (status) =0
*         else   bit 0 of status is set 
  
  
 recall   subr
          sb1    1
          sa2    x1          status word
          zr,x2  rec1        if single recall 
          recall x1          else, auto-recall
          eq     recall 
  
 rec1     recall
          eq     recall 
  
          end 
          ident  rtime
          entry  rtime
          sst 
          b1=1
          list   f
          title  rtime - obtain real time clock reading.
          comment   obtain real time clock reading. 
 rtime    space  4,10 
***       rtime - obtain real time clock reading. 
* 
*         call rtime (status) 
* 
*         entry  none 
* 
*         exit   (status) = response
*         kronos response - 
**t       24/ seconds,36/ milliseconds
* 
*         scope response -
**t       24/ junk,24/ seconds,12/ qm 
* 
*         time is system software clock time since deadstart
*         qm = 1/4096 of a second 
  
  
 rtime    subr
          sb1    1
          bx5    x1 
          rtime  x1 
          sa1    x5 
          bx6    x1          return response as function result 
          eq     rtime
  
          end 
          ident  movech 
          entry  movech 
          sst 
          syscom b1 
 movech   title  movech - mvc> interface for ftn. 
          comment (ftn) move character strings. 
 movech   space  4,10 
*****     movech - mvc> interface for ftn.
* 
*         r. o. anderson.     02/17/76. 
* 
*         ftn interface to the character move subroutine. 
 movech   space  4,10 
***       movech - move character strings.
* 
*         movech source,offsets,destination,offsetd,nchars
* 
*         moves *nchars* from *source* to *destination*.
* 
*         entry  *source* = the address of the first word of the
*                           source string.
*                *offsets* = the character offset (0 - 131071) into 
*                            *source*.
*                *destination* = the address of the first word of 
*                                the destination area.
*                *offsetd* = the character offset (0 - 131071) into 
*                            *destination*. 
*                *nchars* = the number of characters to move. 
*                (b1) = 1.
* 
*         exit   the string has been moved. 
* 
*         uses   x - 1, 2, 3, 4, 5, 6, 7. 
*                b - 2, 3, 4, 5.
*                a - 1, 2, 3, 4, 5, 6, 7. 
* 
*         calls  mvc>.
  
  
          purgmac movech
 movech   macro  source,offsets,dest,offsetd,nchars 
          r=     a1,source
          r=     b2,offsets 
          r=     a2,dest
          r=     b3,offsetd 
          r=     b4,nchars
          rj     =xmvc> 
          endm
 movech   space  4,10 
***       movech provides an ftn callable interface to the university 
*         or arizona character string move subroutine.
* 
*         call movech(src,bcps,dest,bcpd,nchr)
* 
*         entry  *src*  is the variable or array containing the first 
*                       character of the source string. 
*                *bcps* is the beginning character position for the 
*                       string starting in *src* (0 - 131071).
*                *dest* is the variable or array containing the first 
*                       character of the destination string.
*                *bcpd* is the beginning character position for the 
*                       string starting in *dest* (0 - 131071). 
*                *nchr* is the number of characters to move.
* 
*         exit   movech will return after moveing *src* to *dest*.
* 
*         calls  mvc>.
  
  
 movech   subr               entry/exit 
          sb1    1           and b1 shall be 1
          bx2    x1 
          mx0    -6          also used below
          ax2    24 
          bx2    -x0*x2 
          sb2    x2          get character variable offset or zero
          sa2    a1+b1
          sa1    x1          (a1) = address of source string
          sa3    a2+b1
          sa2    x2 
          sb2    b2+x2       (b2) = bcp of source string
          sa2    x3          (a2) = address of destination string 
          ax3    24 
          bx3    -x0*x3 
          sb3    x3          get character variable offset or zero
          sa3    a3+b1
          sa4    x3 
          sb3    b3+x4       (b3) = bcp of destination string 
          sa3    a3+b1
          sa4    x3 
          sb4    x4          (b4) = number of characters to move
          movech a1,b2,a2,b3,b4  move the strings 
          eq     movech      return 
  
          end 
          ident    xcon 
          entry    xcon 
          sst 
          syscom   b1 
xcon      title    xcon - connect/disconnect terminal files.
xcon      space    4,10 
**        xcon - connect a file to a terminal.
* 
*         call xcon(fet,code) 
* 
*         entry    (fet) = fet address
*                  (code) = <0, disconnect (return) file
*                            0, dpc connect 
*                            1, 128 character ascii connect 
*                            2, 256 character ascii connect 
* 
*         exit     file connected to the terminal 
* 
xcon      subr     =
          sb1      1
          sx2      x1              (x2) = fet address 
          sa1      a1+b1
          sa1      x1 
          bx3      x1              (x3) = function code 
          ng       x3,xcon2        if only disconnect 
          status   x2              check if local 
          mx0      11 
          lx0      1
          sa4      x2              get fet+0
          bx4      -x0*x4 
          zr       x4,xcon3        if not local 
xcon1     open     x2,nr,r         check device type
          sa4      x2              clear all but fn+complete
          mx0      43 
          lx0      1
          bx6      x0*x4
          sa6      x2 
          sa4      x2+b1           check for ct device
          ax4      48 
          sx4      x4-2rtt         nos
*         sx4      x4-2rct-774000b nos/be 
          zr       x4,=xxcon       if already ct device, return 
xcon2     evict    x2,r            return local copy
          ng       x3,=xxcon       if only disconnect, return 
xcon3     sa1      x2              set filename for assign
          mx0      48 
          bx6      x0*x1
          sa6      xconb
          sx3      b1             set complete
          bx6      x6+x3
          sa6      x2 
          sx4      x2              save fet address 
*         system   pcc,ar,xcona    create the ct file 
          sx2      x4 
xcon4     sa1      x2              get fet+0
          mx0      43              keep fn+complete 
          lx0      1
          bx1      x0*x1
          mx7      1               ascii bit mask 
          lx7      43 
          nz       x3,xcon5        if not dpc char set
          bx6      x1              store fet+0
          sa6      x2 
          sa1      x2+b1           clear ascii bit
          bx6      -x7*x1 
          sa6      a1 
          eq       =xxcon 
xcon5     sa4      x2+b1           set ascii bit in fet+1 
          bx6      x4+x7
          sb3      x3 
          sb3      b3-b1
          nz       b3,xcon6        if 256 char ascii
          sa6      a4 
          bx6      x1              set fet+0
          sa6      x2 
          eq       =xxcon 
xcon6     sb3      b3-b1
          nz       b3,=xxcon       if invalid mode
          sa6      a4 
          bx6      x1+x3           set odd bit for 256 char ascii 
          sa6      x2              set fet+0
          eq       =xxcon 
  
xcona     data     h*.assign,ct,* 
xconb     data     0
          end 
          ident  xscs 
          entry  xscs 
          sst 
          b1=1
 xscs     title  xscs - scs interface for ftn.
          comment (ftn) sense character set.
 xscs     space  4,10 
*****     xscs - scs interface for ftn. 
* 
*         s. h. jay          83/02/04.
* 
*         ftn interface to the sense character set routine. 
 xscs     space  4,10 
***       xscs provides an ftn callable link to the university
*         of arizona sense character set subroutine.
* 
*         n = xscs(fet) 
* 
*         entry  *fet* is array containing an fet.  a read should 
*                be done on this fet before calling xscs. 
* 
*         exit   *n* = 1 for display code,
*                      0 if buffer empty, 
*                      -1 if ascii. 
* 
*         calls  scs> 
  
  
 xscs     subr               entry/exit 
          sb1    1
          sx2    x1          (x2) = fet address 
          rj     =xscs> 
          eq     xscs        return 
  
          end 
          ident  xsxt 
          entry  xsxt 
          syscom b1 
 xsxt     title  xsxt - sxt> interface for ftn. 
          comment (ftn) convert sixbit to twelvebit.
 xsxt     space  4,10 
*****     xsxt - sxt> interface for ftn.
* 
*         r. o. anderson.     02/17/76. 
* 
*         l. n. shipp.       80/05/09.  fix mcs parameter typo. 
* 
*         ftn interface to the sixbit to twelvebit character conversion 
*         routine.
 mcs      space  4,10 
***       mcs - map character sets into other character sets. 
* 
*         mcs    in=,inlen=,inbs=,out=,outbs=,table=
* 
*         converts the characters in *in* via *table* placing them
*         in *out*. 
* 
*         entry  *in=* the address of the first word of the input 
*                      character string.
*                *inlen=* the length of the input string in words.
*                *inbs=* the byte size (6 or 12) of the input chars.
*                *out=* the address of the first word of the output 
*                       character string buffer. if *outbs* is .le. 
*                       *inbs*, *out* and *in* may point to the same
*                       area. 
*                *outbs=* the byte size (6 or 12) of the output chars.
*                *table=* the address of the character set mapping
*                         table.  this table has 1 entry per word,
*                         right justified with binary zero fill.
*                (b1) = 1.
* 
*         exit   the characters have been mapped. 
* 
*         uses   x - 1, 2, 6, 7.
*                b - 2, 3, 4, 5.
*                a - 1, 2, 6. 
* 
*         calls  sxs>, sxt>, txs>, or txt>. 
  
  
          purgmac mcs 
 mcs      macroe in,inlen,out,inbs,outbs,table
          r=     b2,in
          r=     b3,inlen 
          r=     b4,out 
          r=     b5,table 
          ifeq   inbs,6,2 
 ^%s"mcs1 micro  1,, s
          skip   4
          ifeq   inbs,12d,2 
 ^%s"mcs1 micro  1,, t
          skip   1
          err    input byte size must be 6 or 12. 
          ifeq   outbs,6,2
 ^%s"mcs2 micro  1,, s
          skip   4
          ifeq   outbs,12d,2
 ^%s"mcs2 micro  1,, t
          skip   1
          err    output byte size must be 6 or 12.
          rj     =x'^%s"mcs1'x'^%s"mcs2'> 
          endm
 xsxt     space  4,10 
***       xsxt provides an ftn callable link to the university of 
*         arizona sixbit to twelvebit character conversion routine. 
* 
*         call xsxt(in,len,out,tbl) 
* 
*         entry  *in*   is a variable or array containing the 
*                       characters to be converted (10 per word). 
*                *len*  is the word length of the array *in*. 
*                *out*  is the variable or array to receive the 
*                       converted characters (5 per word).
*                *tbl*  is an array containing the conversion table.
*                       this table contains 1 character per word, 
*                       right justified, with binary zero fill. 
* 
*         exit   xsxt will return after doing the conversion. 
* 
*         calls  sxt>.
  
  
 xsxt     subr               entry/exit 
          sb1    1           and b1 shall be 1
          sb2    x1          (b2) = input area address
          sa1    a1+b1
          sa2    x1 
          sb3    x2          (b3) = word length of input
          sa1    a1+b1
          sb4    x1          (b4) = output area address 
          sa1    a1+b1
          sb5    x1          (b5) = conversion table address
          mcs    in=b2,inlen=b3,out=b4,table=b5,inbs=6,outbs=12 
          eq     xsxt        return 
  
          end 
          ident  xtxs 
          entry  xtxs 
          syscom b1 
 xtxs     title  xtxs - txs> interface for ftn. 
          comment (ftn) convert twelvebit to sixbit.
 xtxs     space  4,10 
*****     xtxs - txs> interface for ftn.
* 
*         r. o. anderson.     02/17/76. 
* 
*         l. n. shipp.       80/05/09.  fix mcs parameter typo. 
* 
*         ftn interface to the twelvebit to sixbit character conversion 
*         routine.
 mcs      space  4,10 
***       mcs - map character sets into other character sets. 
* 
*         mcs    in=,inlen=,inbs=,out=,outbs=,table=
* 
*         converts the characters in *in* via *table* placing them
*         in *out*. 
* 
*         entry  *in=* the address of the first word of the input 
*                      character string.
*                *inlen=* the length of the input string in words.
*                *inbs=* the byte size (6 or 12) of the input chars.
*                *out=* the address of the first word of the output 
*                       character string buffer. if *outbs* is .le. 
*                       *inbs*, *out* and *in* may point to the same
*                       area. 
*                *outbs=* the byte size (6 or 12) of the output chars.
*                *table=* the address of the character set mapping
*                         table.  this table has 1 entry per word,
*                         right justified with binary zero fill.
*                (b1) = 1.
* 
*         exit   the characters have been mapped. 
* 
*         uses   x - 1, 2, 6, 7.
*                b - 2, 3, 4, 5.
*                a - 1, 2, 6. 
* 
*         calls  sxs>, sxt>, txs>, or txt>. 
  
  
          purgmac mcs 
 mcs      macroe in,inlen,out,inbs,outbs,table
          r=     b2,in
          r=     b3,inlen 
          r=     b4,out 
          r=     b5,table 
          ifeq   inbs,6,2 
 ^%s"mcs1 micro  1,, s
          skip   4
          ifeq   inbs,12d,2 
 ^%s"mcs1 micro  1,, t
          skip   1
          err    input byte size must be 6 or 12. 
          ifeq   outbs,6,2
 ^%s"mcs2 micro  1,, s
          skip   4
          ifeq   outbs,12d,2
 ^%s"mcs2 micro  1,, t
          skip   1
          err    output byte size must be 6 or 12.
          rj     =x'^%s"mcs1'x'^%s"mcs2'> 
          endm
 xtxs     space  4,10 
***       xtxs provides an ftn callable link to the university of 
*         arizona twelvebit to sixbit character conversion routine. 
* 
*         call xtxs(in,len,out,tbl) 
* 
*         entry  *in*   is a variable or array containing the 
*                       characters to be converted (5 per word).
*                *len*  is the word length of the array *in*. 
*                *out*  is the variable or array to receive the 
*                       converted characters (10 per word). 
*                *tbl*  is an array containing the conversion table.
*                       this table contains 1 character per word, 
*                       right justified, with binary zero fill. 
* 
*         exit   xtxs will return after doing the conversion. 
* 
*         calls  txs>.
  
  
 xtxs     subr               entry/exit 
          sb1    1           and b1 shall be 1
          sb2    x1          (b2) = input area address
          sa1    a1+b1
          sa2    x1 
          sb3    x2          (b3) = word length of input
          sa1    a1+b1
          sb4    x1          (b4) = output area address 
          sa1    a1+b1
          sb5    x1          (b5) = conversion table address
          mcs    in=b2,inlen=b3,out=b4,table=b5,inbs=12,outbs=6 
          eq     xtxs        return 
  
          end 
          ident  xvfn 
          entry  xvfn 
          sst 
          syscom b1 
          title  xvfn - validate file name. 
          comment (ftn) validate file name. 
 xvfn     space  4,10 
***       xvfn - validate file name.
* 
*         ans = xvfn (lfn)
* 
*         entry  *lfn* = logical file name.  trailing spaces will be
*                        deleted before name is validated.
* 
*         exit *ans* = 0 if file name is valid. 
  
  
 xvfn     subr               entry/exit 
          sb1    1
          sb6    xvfna
          sb7    b1 
          rj     =xmfs>      word align the lfn 
          sa1    xvfna
          rj     =xbtz>      convert blanks to 00b
          bx1    x6 
          rj     =xvfn>      check out the name 
          bx6    x1          set function value 
          eq     xvfnx       return 
  
 xvfna    bss    1
  
          end 
          ident  retfile
          sst 
          entry  retfile,unlfile
          syscom b1 
 retfile  title  retfile - return/unload a file.
          comment return/unload a file. 
          space  4,10 
***       retfile - return/unload a file. 
* 
*         call retfile(lfn) 
*         call unlfile(lfn) 
* 
*         entry  lfn = a hollerith string or a character string 
*                      containing the name of the file to be returned 
*                      (retfile) or unloaded (unlfile).  spaces are 
*                      removed from lfn before processing.
* 
*         exit   file is gone.
 retfile  space  4,10 
**        retfile - close/return a file.
  
  
 retfile  subr               entry/exit 
          sb1    1           b1=1 
          rj     sff         set file name in fet 
          close  retfilea,unload,rcl
          eq     retfilex    return 
 unlfile  space  4,10 
**        unlfile - close/unload a file.
  
  
 unlfile  subr               entry/exit 
          sb1    1           b1=1 
          rj     sff         set file name in fet 
          close  retfilea,unload,rcl
          eq     unlfilex    return 
 sff      space  4,10 
**        sff - set file name in fet. 
* 
*         entry  (x1) = ftn parameter pointer for lfn.
* 
*         exit   (retfilea) contains lfn + complete bit.
* 
*         uses   x - 1, 2, 6, 7.
*                b - 2, 3, 4, 5, 6, 7.
*                a - 2, 6.
* 
*         calls  btz>, macwal=. 
  
  
 sff      subr               entry/exit 
          rj     =xmacwal=   get the file name
          bx1    x2 
          rj     =xbtz>      delete any spaces
          sa1    retfilea 
          sx1    b1 
          bx6    x6+x1       add complete bit 
          sa6    retfilea    stash in fet 
          eq     sffx        return 
  
 retfilea vfd    42/**,18/1 
          con    100b        first
          con    100b        in 
          con    100b        out
          con    101b        limit
  
          end 
