.PROC,CREOPL*I,
A "- NOS/BE pl1a"                      = (*N=PL1A,*F),
B "- NOS/BE pl1b"                      = (*N=PL1B,*F),
T "- COMPASS pl2"                      = (*N=PL2,*F),
UN "- NOS/BE perm file ID"             = (*N=,*F),
.
.HELP
 The CREOPL procedure CREates an update format OPL cotaining common decks
 from NOS/BE released pl1a, pl1b and COMPASS pl2. It is used in compiling
 NOS/VE real-state COMPASS source.

 Parameter   Default   Description
   Name       Value

  [a]         pl1a     NOS/BE pl1a
  [b]         pl1b     NOS/BE pl1b
  [l]         pl2      COMPASS pl2
   un                  NOS/BE permanent file ID

.HELP,A
 The A parameter specifies the file containing NOS/BE pl1a.
.HELP,B
 The B parameter specifies the file containing NOS/BE pl1b.
.HELP,T
 The T parameter specifies the file containing COMPASS pl2.
.HELP,UN
 The UN parameter specifies a permanent file ID used to reference the input
 files (if they are not already local) and catalog file OPL.
.ENDHELP
.IF,SYS.EQ.NOS.REVERT. NOS/BE PROC ONLY
GETFILE,A,A,UN,#A=YES.
GETFILE,B,B,UN,#A=YES.
GETFILE,T,T,UN,#A=YES.
UPDATE,Q,P=A,I=UPDR1,R,S=TEXTSA,C=0,L=0.
UPDATE,Q,P=B,I=UPDR2,R,S=TEXTSB,C=0,L=0.
UPDATE,Q,P=T,I=UPDR3,R,S=TEXTS2,C=0,L=0.
REQUEST,OPL,PF.
REWIND,TEXTSA,TEXTSB,TEXTS2,UPDR5.
UPDATE,N=OPL,I=UPDR4,C=0,L=0.
REPFILE,OPL,OPL,#UN=UN.
RETURN,TEXTSA,TEXTSB,TEXTS2.
RETURN,A,B,T,OPL,UPDR1,UPDR2,UPDR3,UPDR4,UPDR5.
EXIT.
RETURN,TEXTSA,TEXTSB,TEXTS2.
RETURN,A,B,T,OPL,UPDR1,UPDR2,UPDR3,UPDR4,UPDR5.
.DATA,UPDR1
*C COMSDST,COMPMRM,COMPMRA,COMSMCR,SSYS
.DATA,UPDR2
*C PFCOM,COMCMAC
.DATA,UPDR3
*C COMCCDD,COMCCIO,COMCSYS
.DATA,UPDR4
*READ TEXTSA
*READ TEXTSB
*READ TEXTS2
*READ UPDR5
.DATA,UPDR5
*COMDECK COMCWTW
          CTEXT  COMCWTW - WRITE WORDS FROM WORKING BUFFER.
 WTW      SPACE  4
          IF     -DEF,QUAL$,1
          QUAL   COMCWTW
          BASE   D
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992.
 WTW      SPACE  4
***       WTW - WRITE WORDS FROM WORKING BUFFER.
*         D. #A. CAHLANDER.   70/11/29.
*         R. E. TATE.        73/11/04.
 WTW      SPACE 4
***       WTW - INTERNAL NOTICE
*               THIS COMMON DECK HAS BEEN COPIED FROM THE NOS OPL AND PUT
*         INTO THE NOS/VE DECK RAM$CREOPL.  THIS COMMON DECK IS NEEDED
*         BY NOS/BE TO ASSEMBLE THE DUAL STATE ROUTINES.  IF THE NOS
*         COMMON DECK CHANGES THEN THE NOS/VE DECK RAM$CREOPL SHOULD
*         BE UPDATED WITH THE NEW VERSION OF COMCWTW, AND THIS NOTICE
*         SHOULD BE INCLUDED WITH THAT UPDATE.
 WTW      SPACE  4
***              WTW TRANSFERS DATA FROM #A WORKING BUFFER TO #A CIO
*         BUFFER.  THIS DECK ALSO CONTAINS DCB=, AND WTX=.
*         IF THE BUFFER BECOMES SUFFICIENTLY FULL TO REQUIRE WRITING,
*         THE THRESHOLD CONDITION TO ISSUE WRITE FUNCTIONS
*         IS BUFFER HALF FULL FOR BUFFERS LARGER
*         THAN 511 DECIMAL WORDS, AND BUFFER TOTALLY
*         FULL FOR SMALLER BUFFERS.  IF THE SYMBOL
*         WTX$ IS DEFINED, THEN THE THRESHOLD IS
*         BUFFER FULL FOR ALL BUFFER SIZES.
*         WTW WILL PERFORM #A *WRITE* FUNCTION UNLESS THE SYMBOL *WRIF$*
*         IS DEFINED. IN THIS CASE, THE CIO FUNCTION THAT IS IN THE FET
*         WILL BE REISSUED.  #A *WRITEW* REQUEST MAY READ DATA FROM
*         BEYOND THE END OF THE WORKING BUFFER, THUS CAUSING AN ABORT
*         IF THE LAST WORD ADDRESS OF THE BUFFER IS WITHIN 4 WORDS OF
*         FL.
*
*         WHEN CALLING CIO= FROM THIS ROUTINE B6 AND B7
*         MUST CONTAIN WORKING STORAGE BUFFER ADDRESS,
*         AND NUMBER OF WORDS TO TRANSFER RESPECTIVELY
*         AS ERROR PROCESSING ROUTINES DEPEND UPON
*         THESE REGISTERS.
*
*         ENTRY  (X2) = ADDRESS OF FET FOR FILE.
*                (B6) = FWA WORKING BUFFER.
*                (B7) = WORD COUNT OF WORKING BUFFER.
*                IF (B7) = 0, NO TRANSFER WILL BE PERFORMED.
*
*         EXIT   (X2) = ADDRESS OF FET FOR FILE.
*                (B6) = ADDRESS OF NEXT WORD TO BE TRANSFERRED FROM
*                       WORKING BUFFER.
*                (B7) = 0 IF TRANSFER COMPLETE.
*                     = REMAINING WORD COUNT IF *CIO=* WAS CALLED TO
*                       WRITE DATA AND RETURNED AN ERROR STATUS.
*                (X7) = ERROR STATUS IF (B7) .NE. 0.
*
*         USES   X - 1, 2, 3, 4, 6, 7.
*                B - 1, 2, 3, 4, 5, 6, 7.
*                #A - 1, 2, 3, 4, 6, 7.
*
*         CALLS  CIO=.


 WTW18    SX6    B3+B4       ADVANCE IN
          SB3    B3+B4
          SB6    B6+B4
          SB7    B7-B4
          NE     B3,B5,WTW19 IF IN " LIMIT
          SA1    X2+B1       IN = FIRST
          SX6    X1
 WTW19    SA6    X2+2        UPDATE IN
          NZ     B7,WTW1     IF NOT END OF TRANSFER

 WTW=     PS                 ENTRY/EXIT
 WTW1     SA1    X2+3        (B4) = OUT
          SA3    X2+2        (B3) = IN
          IF     -DEF,B1=1,1
          SB1    1
          SA4    A1+B1       (B5) = LIMIT
          ZR     B7,WTW=     IF WORKING BUFFER EMPTY
          SB4    X1
          SA1    X2+B1       (B2) = FIRST
          SB3    X3
          SB5    X4
          SB2    X1
          SA1    B6          READ FIRST WORD
          NE     B2,B4,WTW2  IF OUT " FIRST
          SB4    B5
 WTW2     LT     B3,B4,WTW3  IF NO END AROUND
          SB4    B5+1
 WTW3     SB4    B4-B1       CALCULATE FREE DATA SPACE
          SB4    B4-B3       (B4) = TRANSFER LENGTH
          ZR     B4,WTW13    IF NO ROOM
          BX7    X1
          LE     B4,B7,WTW4  IF NOT ENOUGH ROOM
          SB4    B7

*         INITIALIZE REGISTERS FOR TRANSFER.

 WTWA     BSS    0
 WTW4     SA3    WTWC        PRESET CMU CODE AND VOID STACK
          RJ     WTW16
*         SA1    A1+B1       (NO CMU)
*         SX4    B4-B1       (NO CMU)
*         MX6    -3          (NO CMU)
*         SA7    B3          (NO CMU)
*
*         GT     B4,B1,WTW14  IF MORE THAN 1 WORD  (CMU)
*         BX4    X4-X4       (CMU)
*         SA7    B3          (CMU)

 WTW5     BX3    -X6*X4      NUMBER OF ODD WORDS
          AX4    3           NUMBER OF BLOCKS
          ZR     X3,WTW7     IF NO ODD WORDS

*         TRANSFER UP TO 7 WORDS.

 WTW6     SX3    X3-1
          BX7    X1
          SA1    A1+B1
          SA7    A7+B1
          NZ     X3,WTW6     LOOP

*         PRE-READ REGISTERS.

 WTW7     ZR     X4,WTW18    IF NO BLOCKS
          SB5    X2          (B5) = FET ADDRESS
          SA2    A1+B1
          SB2    B1+B1       (B2) = 2
          SA3    A2+B1
          SB3    X4          (B3) = BLOCK COUNT
          SA4    A3+B1

*         TRANSFER 8 WORD BLOCKS.

 WTW8     BX6    X1
          LX7    X2
          SA1    A3+B2
          SA2    A4+B2
          SA6    A7+B1
          SB3    B3-B1
          SA7    A6+B1
          BX6    X3
          LX7    X4
          SA3    A1+B2
          SA4    A2+B2
          SA6    A6+B2
          SA7    A7+B2
          BX6    X1
          LX7    X2
          SA1    A3+B2
          SA2    A4+B2
          SA6    A6+B2
          SA7    A7+B2
          BX6    X3
          LX7    X4
          SA3    A1+B2
          SA4    A2+B2
          SA6    A6+B2
          SA7    A7+B2
          NZ     B3,WTW8     LOOP

*         WRITE EXIT.

          SA3    B5+B2       READ IN
          SA1    A3+B2       (B5) = LIMIT
          SX2    B5
          SB5    X1
          SA4    X2          CHECK BUFFER STATUS
 WTW9     SB6    B6+B4
          SB7    B7-B4
          SB3    X3+B4       ADVANCE IN
          SX6    X3+B4
          LX4    59-0
          SA3    X2+B1       READ FIRST
          NE     B3,B5,WTW10 IF IN " LIMIT
          SX6    X3+         IN = FIRST
 WTX$     IF     DEF,WTX$
 WTW10    EQ     WTW19       CLEAN UP AND RETURN
 WTX$     ELSE

*         TRY TO BUFFER AHEAD.

 WTW10    PL     X4,WTW19    IF BUFFER BUSY
          SA1    X2+3        READ OUT
          SA6    X2+2        STORE IN
          SB2    X3          (LIMIT-FIRST)
          IX6    X1-X6       (OUT-IN)
          SX7    B5-B2
          LX3    X6,B1       2*(OUT-IN)
          AX6    60          SIGN OF (OUT-IN)
          BX4    X6-X7       INVERT BUFFER IF IN \ OUT
          IX6    X4-X3       BUFFER SIZE - 2*(OUT-IN)
          NG     X6,WTW12    IF BUFFER THRESHOLD NOT REACHED
          AX7    9
          ZR     X7,WTW12    IF BUFFER NOT BIG ENOUGH TO WRITE AHEAD
 WTX$     ENDIF
 WRIF$    IF     DEF,WRIF$
 WTW11    SA1    X2          RE-ISSUE CURRENT WRITE FUNCTION
          SX6    774B
          BX7    X6*X1
          RJ     =XCIO=
 WRIF$    ELSE   1
 WTW11    WRITE  X2
          NZ     X7,WTW=     IF ERROR IN LAST *CIO* REQUEST
 WTW12    NZ     B7,WTW1     IF NOT DONE
          JP     WTW=        RETURN

*         DUMP CIRCULAR BUFFER.

 WTW13    SA1    X2          CHECK BUFFER STATUS
          LX1    59-0
          NG     X1,WTW11    IF NOT BUSY
          ZR     X1,WTW11    IF BLANK FET
          JP     WTW1        CONTINUE WRITE

*         MOVE DATA WITH CMU.

 WTW14    SX4    B4-819
          PL     X4,WTW15    IF TOO BIG FOR CMU
          SX4    B4          10 * WORDS = CHARACTERS
          LX6    X4,B1
          BX1    X0          SAVE X0
          LX4    3
          IX6    X4+X6
          SX7    B6          SET SOURCE ADDRESS
          SX4    B3          SET DESTINATION ADDRESS
          LX7    30
          BX4    X4+X7
          MX7    -4
          BX3    X7*X6       EXTRACT UPPER PORTION
          BX6    -X7*X6      EXTRACT LOWER PORTION
          LX3    48-4
          BX4    X4+X3
          LX6    26
          BX6    X4+X6
          AX3    51
          SA6    WTWC        STORE DESCRIPTOR WORD
          IM     WTWC        MOVE DATA
          BX0    X1          RESTORE X0
          ZR     X3,WTW18    IF NO WRITE EXIT
          SA4    X2
          SX3    B3          RESET IN
          JP     WTW9

 WTWB     BSS    0
 WTW15    SA1    A1+B1       MOVE DATA WITHOUT CMU
          SX4    B4-B1
          MX6    -3
          SA7    B3
          JP     WTW5

*         CMU PRESET CODE.
*         WWTC IS READ UP AND THEN RETURN JUMPED TO IN ORDER TO VOID
*         STACK.  WWTC IS ALSO USED AS THE CMU DESCRIPTOR WORD

 WTWC     GT     B4,B1,WTW14 IF MORE THAN 1 WORD TO MOVE  (CMU)
          BX4    X4-X4
          SA7    B3
 WTW16    EQU    WTWC        USED TO VOID STACK

*         PRESET FOR CMU CODE.

          SA4    CMUR        CHECK IF CMU AVAIALABLE
          SB4    WTWA
          NG     X4,WTW17    IF CMU
          SA3    WTWB
 WTW17    BX6    X3
          SA6    B4
          JP     WTW1

 WTX      SPACE  4
**        WTX - WRITE EXIT.
*         IF BUFFER IS BUSY, RETURN.
*         OTHERWISE, WORD COUNT OF BUFFER IS CHECKED, AND #A WRITE
*         FUNCTION IS REQUESTED IF NECESSARY.
*
*         ENTRY  (A2) = ADDRESS OF IN.
*                (A3) = ADDRESS OF FIRST.
*                (A4) = RETURN ADDRESS.
*                (B3) = IN+1.
*                (B4) = OUT.
*                (B5) = LIMIT.
*                (X2) = IN
*
*         EXIT   TO RETURN ADDRESS.
*
*         CALLS  NONE.


 WTX=     SA1    A3-B1       CHECK BUFFER STATUS
          SX6    X2          STORE IN
          LX1    59
          SA6    A2
 WTX$     IF     -DEF,WTX$
          PL     X1,WTX1     IF BUFFER BUSY

*         IF BUFFER IS NOT BUSY, CHECK SIZE OF BUFFER.
*         ISSUE WRITE IF THRESHOLD IS REACHED.

          SA1    A2+B1       REREAD OUT
          SA3    A3          FIRST
          SB4    X1
          SX6    B4-B3       (OUT-IN+1)
          SB2    X3          (LIMIT-FIRST)
          LX3    X6,B1       2*(OUT-IN+1)
          SX7    B5-B2
          AX6    60          SIGN OF (OUT-IN+1)
          BX4    X6-X7       INVERT BUFFER IF IN+1 \ OUT
          IX6    X4-X3       BUFFER SIZE - 2*(OUT-IN+1)
          NG     X6,WTX1     IF BUFFER THRESHOLD NOT REACHED
          AX7    9
          ZR     X7,WTX1     IF BUFFER NOT BIG ENOUGH TO WRITE AHEAD
 WRIF$    IF     DEF,WRIF$
          SA1    A3-B1       RE-ISSUE CURRENT WRITE FUNCTION
          SX6    774B
          BX7    X6*X1
          SX2    A1          SET FET ADDRESS
          RJ     =XCIO=
 WRIF$    ELSE   1
          WRITE  A3-B1

 WTX$     ENDIF
 WTX1     SB2    A4          SET RETURN ADDRESS
          SX2    A3-B1       RESET (X2)
          JP     B2          RETURN
 DCB      SPACE  4
**        DCB - DUMP CIRCULAR BUFFER.
*         IF BUFFER IS BUSY, RETURN.
*         IF BUFFER IS NOT BUSY, REQUEST WRITE FUNCTION AND RETURN.
*
*         ENTRY  (A2) = ADDRESS OF IN.
*                (A3) = ADDRESS OF FIRST.
*                (A4) = RETURN ADDRESS.
*                (B2) = FET STATUS READ PRIOR TO READ OF OUT.
*                (X2) = IN.
*
*         EXIT   TO RETURN ADDRESS - 1.
*                (X2) = FET ADDRESS.


 DCB=     SX1    B2          CHECK BUFFER STATUS
          SX6    X2          STORE IN
          LX1    59
          SA6    A2
          NG     X1,DCB1     IF NOT BUSY
          ZR     X1,DCB1     IF BLANK FET
          SX2    A3-B1       RESET FET ADDRESS
          SB2    A4-B1       CONTINUE WRITE
          JP     B2
 WRIF$    IF     DEF,WRIF$
 DCB1     SA1    A3-B1       RE-ISSUE CURRENT WRITE FUNCTION
          SX6    774B
          BX7    X6*X1
          SX2    A1          SET FET ADDRESS
          RJ     =XCIO=
 WRIF$    ELSE   1
 DCB1     WRITE  A3-B1
          SB2    A4-B1       CONTINUE WRITE
          JP     B2
          SPACE  4
          BASE   *
 QUAL$    IF     -DEF,QUAL$
          QUAL   *
 WTW=     EQU    /COMCWTW/WTW=
 WTX=     EQU    /COMCWTW/WTX=
 DCB=     EQU    /COMCWTW/DCB=
 QUAL$    ENDIF
          ENDX
/EOR
