ASMB,Q,C
*     NAME:   KHAR  
*     SOURCE: 92070-18265 
*     RELOC:  92070-1X265 
*     PGMR:   GAA,HLC 
* 
* 
*  **************************************************************** 
*  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979.  ALL RIGHTS      * 
*  * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,       * 
*  * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * 
*  * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.        * 
*  **************************************************************** 
* 
* 
      NAM KHAR,7  92070-1X265  REV.1941  790606 
      EXT .ENTR,.DFER 
      ENT SETSB,SETDB,KHAR,CPUT,ZPUT
* 
*     THESE ROUTINES BUILD AND TEAR APART STRINGS FOR FORTRAN 
*     PROGRAMS
* 
* 
*     SETSB: SETS UP THE STRING SOURCE BUFFER AND ITS LIMITS
* 
*     CALL SETSB(IBUF,ISCH,ISLIM) 
* 
*          WHERE: IBUF IS THE BUFFER ADDRESS
*                 ISCH IS THE CURRENT CHARACTER POSITION (UPDATED BY KHAR)
*                      YOU SHOULD INITIALIZE IT TO 1 FOR THE FIRST
*                      CHARACTER IN IBUF (I.E. LEFT HALF OF FIRST WORD
*                      NOTE THAT THIS IS THE SAME CONVENTION USED IN 'NAMR' 
*                 ISLIM IS THE NUMBER OF CHARACTERS IN IBUF 
* 
*     SETDB: SETS UP THE DESTINATION BUFFER 
* 
*     CALL SETDB(IDBUF,IDCH)
* 
*          WHERE:  IDBUF IS THE DESTINATION BUFFER
*                  IDCH  IS THE DESTINATION CARACTER COUNT
*                        YOU SHOULD INITIALIZE IDCH TO ZERO BEFOR CALLING 
*                        CPUT OR ZPUT.  IDCH IS UPDATED BY CPUT AND ZPUT
*                        AND REFLECTS THE TRUE CHARACTER COUNT IN IDBUF 
*                        NO TEST ARE DONE FOR EXCEEDING IDBUF.
*                        IDCH MAY BE DECREMENTED TO DELETE CHARACTERS OR
*                        EVEN SET BACK TO ZERO TO CLEAR THE BUFFER
* 
*     KHAR  : GET THE NEXT SOURCE CHARACTER 
* 
*     IC=KHAR(IC2)
* 
*          WHERE:  IC AND IC2 ARE TO RECEIVE THE CHARACTER
*                  BOTH WILL BE ZERO IF THERE ARE NO MORE CHARACTERS
*                  THE CHARACTER WILL BE IN THE HIGH HALF OF THE WORD 
*                  WITH A BLANK PAD IN THE LOW HALF (FORTRAN 1H CONVENTION).
* 
*     CPUT : PUTS THE CHARACTER IN THE DESTINATION BUFFER 
* 
*     CALL CPUT(ICR2) 
* 
*          WHERE:  ICR2 IS THE CHARACTER TO BE PUT OUT (IN HIGH HALF OF WORD) 
* 
*     ZPUT : PUTS A STRING IN THE DESTINATION BUFFER
* 
*     CALL ZPUT(I2BUF,IFRST,NO) 
* 
*          WHERE:  I2BUF  IS THE STRING BASE ADDRESS
*                  IFRST  IS THE FIRST CHARACTER TO BE PUT
*                  NO     IS THE NUMBER OF CHARACTERS TO BE PUT 
* 
*     NOTE SETSB AND SETDB TAKE ADDRESSES ONLY.  THIS MEANS THAT YOU
*     MAY RESET THE POINTERS ( ISCH AND IDCH) AND EVEN THE SOURCE LIMIT 
*     (ISLIM) WITHOUT CALLING SETSB OR SETDB. 
* 
*     ANY QUESTIONS SEE : GEORGE ANZINGER 
* 
ISB   NOP 
ISCH  NOP 
ISLM  NOP 
SETSB NOP 
      JSB .ENTR 
      DEF ISB 
      JMP SETSB,I   SIMPLE ISN'T
* 
IDB   NOP 
IDCH  NOP 
SETDB NOP 
      JSB .ENTR 
      DEF IDB 
      JMP SETDB,I   EVEN SIMPLER
* 
KHAR  NOP           GET CHAR FORM SOURCE
      LDB KHAR,I    GET RETURN ADDRESS
      STB RTN       AND SAVE IT 
      ISZ KHAR      STEP TO THE RETURN CHAR. ADDRESS
      CLA           PRESET A FOR END OF LINE
      LDB ISCH,I    GET THE CHARACTER POSITION
      CMB,INB,SZB,RSS IF ZERO THEN
      JMP KEX       HE DIDN'T CALL THE SET ADDRESS ROUTINE YET
* 
      ADB ISLM,I    CHECK IF BEYOND THE LIMIT 
      SSB           WELL? 
      JMP KEX       YES RETURN ZERO 
* 
      LDB ISB       GET THE BUFFER ADDRESS
      CLE,ELB       CHANGE TO CHAR
      ADB ISCH,I    ADD THE POSITION
      ADB N1        SUBTRACT FOR 1=1'ST CHAR. 
      CLE,ERB       SHIFT BACK TO FORM ACTUAL ADDRESS 
      LDA B,I       GET THE CHAR
      SEZ           IF IN LOW HALF
      ALF,ALF       ROLL IT UP
      AND C377      ISOLATE IT
      IOR B40       PAD IT
      ISZ ISCH,I    STEP THE CHARACTER COUNT
KEX   LDB KHAR,I    GET THE ADDRESS OF THE PLACE TO STORE IT
      STA B,I       SET THE RETURN CHAR.
      JMP RTN,I     AND RETURN
* 
N1    DEC -1
C377  BYT 377 
B40   OCT 40
* 
CPUT  NOP 
      LDA CPUT,I    PUT A CHAR. 
      STA RTN       SAVE THE RETURN ADDRESS 
      ISZ CPUT      STEP TO THE CHAR ADDRESS
      LDB IDB       GET THE ADDRESS 
      CLE,ELB       SHIFT IT
      ADB IDCH,I    ADD THE OFFSET (SHOULD START AT ZERO) 
      CLE,ERB       MAKE WORD ADDRESS 
      LDA CPUT,I    GET THE CHAR TO BE PUTR 
      LDA A,I 
      SEZ           PUT IN THE CORRECT HALF 
      ALF,ALF 
      XOR B,I       MERGE IT
      SEZ 
      AND B377      ISOLATE THE CORRECT 
      SEZ,RSS       HALF
      AND C377      AND 
      XOR B,I       FINISH THE MERGE
      STA B,I       SET THE NEW CHAR
      ISZ IDCH,I    STEP THE COUNT
      JMP RTN,I     AND RETURN
* 
B377  OCT 377 
RTN   NOP 
* 
ISBUF NOP 
ISPO  NOP 
ISCO  NOP 
ZPUT  NOP 
      JSB .ENTR     USE .ENTR WHERE IT ISN'T CALLED MUCH
      DEF ISBUF 
      CCA           CONVERT 
      ADA ISCO,I    THE COUNT AND POSITION
      ADA ISPO,I    INTO A LIMIT
      STA ISCO      AND SAVE IT 
      JSB .DFER     SAVE THE CURRENT SOURCE 
      DEF ISBS      BUFFER
      DEF ISB       POINTERS
      LDA ISBUF     SET UP NEW TEMPS
      STA ISB 
      LDA ISPO,I
      STA ISPO      DON'T WIPE HIS NUMBERS
      LDA DISPO     SET ADDRESS 
      STA ISCH      FOR KHAR
      LDA DISCO 
      STA ISLM
LOOP  JSB KHAR
      DEF *+2 
      DEF SETDB 
      SZA,RSS       END OF BUFFER?
      JMP EX3       YES 
* 
      JSB CPUT      PUT THE CHAR
      DEF *+2 
      DEF SETDB 
      JMP LOOP
* 
EX3   JSB .DFER     RESTORE THE SOURCE BUFFERS
      DEF ISB 
      DEF ISBS
      JMP ZPUT,I    AND RETURN
* 
ISBS  BSS 3 
DISCO DEF ISCO
DISPO DEF ISPO
A     EQU 0 
B     EQU 1 
      END 
                                                                                                                            