!* MODIFIED 08/04/82  02.00
!*
!              
!                         EXPORT LIST
!
!
%ROUTINESPEC F77 STOP(%HALFINTEGER PTYPE,%INTEGER VAL)
%ROUTINESPEC F77 PAUSE (%HALFINTEGER PTYPE,%INTEGER VAL)
%ROUTINESPEC F77 RTERR(%HALFINTEGER ERRNO)
%ROUTINESPEC F77 IOERR(%HALFINTEGER ERRNO)
%HALFINTEGERFNSPEC F77 CONCAT(%INTEGER OUTPUTBASE,
      %HALFINTEGER OUTPUT DISP,OUTPUT LEN,%INTEGER COUNT,
ADDRINPUTDESCS,%HALFINTEGER SPACEFILL)
%ROUTINESPEC F77COPY (%INTEGER SCE BASE,%HALFINTEGER SCE DISP,
SOURCE LEN,%INTEGER TARGET BASE,%HALFINTEGER TARGET DISP,TARGET LEN)
%INTEGERFNSPEC F77 INDEX (%INTEGER SEARCHBASE,
%HALFINTEGER SEARCHDISP,SEARCHLEN,%INTEGER KEYBASE,%HALFINTEGER KEYDISP,
KEYLEN)
%ROUTINESPEC F77 CMULTC(%INTEGER AD,%REAL R1,C1,R2,C2)
%ROUTINESPEC F77 CDIVC(%INTEGER AD,%REAL R1,C1,R2,C2)
%INTEGERFNSPEC F77 CXREL(%REAL R1,C1,R2,C2)
%INTEGERFNSPEC F77 CHREL(%HALFINTEGER OP,%INTEGER LBASE,
  %HALFINTEGER LDISP,LLEN,%INTEGER RBASE,%HALFINTEGER RDISP,RLEN)

%INTEGERFNSPEC F77 IABS(%INTEGERNAME I,%INTEGER J)
%REALFNSPEC F77 ABS(%REALNAME X,%INTEGER I)
%INTEGERFNSPEC F77 MOD(%INTEGERNAME I,%INTEGER II,
                        %INTEGERNAME J,%INTEGER JJ)
%REALFNSPEC F77 AMOD(%REALNAME X,%INTEGER XX,
                          %REALNAME Y,%INTEGER YY)
%INTEGERFNSPEC F77 ISIGN(%INTEGERNAME I,%INTEGER II,
                        %INTEGERNAME J,%INTEGER JJ)
%REALFNSPEC F77 SIGN (%REALNAME X,%INTEGER XX,
                     %REALNAME Y,%INTEGER YY)
%INTEGERFNSPEC F77 NINT(%REALNAME X,%INTEGER I)
%REALFNSPEC F77 AINT(%REALNAME X,%INTEGER I)
%REALFNSPEC F77 ANINT(%REALNAME X,%INTEGER I)
%INTEGERFNSPEC F77 IDIM(%INTEGERNAME I,%INTEGER II,
                 %INTEGERNAME J,%INTEGER JJ)
%REALFNSPEC F77 DIM(%REALNAME X,%INTEGER XX,
                   %REALNAME Y,%INTEGER YY)
%INTEGERFNSPEC F77 LLE(%INTEGER A0,%HALFINTEGER D0,L0,%INTEGER LL0,A1,
%HALFINTEGER D1,L1,%INTEGER LL1)
%INTEGERFNSPEC F77 LGT(%INTEGER A0,%HALFINTEGER D0,L0,%INTEGER LL0,A1,
%HALFINTEGER D1,L1,%INTEGER LL1)
%INTEGERFNSPEC F77 LLT(%INTEGER A0,%HALFINTEGER D0,L0,%INTEGER LL0,A1,
%HALFINTEGER D1,L1,%INTEGER LL1)
%INTEGERFNSPEC F77 LGE(%INTEGER A0,%HALFINTEGER D0,L0,%INTEGER LL0,A1,
%HALFINTEGER D1,L1,%INTEGER LL1)
%INTEGERFNSPEC F77 LEN (%INTEGER A0,%HALFINTEGER D0, L0,%INTEGER LL0)
%ROUTINESPEC F77 PCHAR(%INTEGER ADDRTARGETDESC,ADDRSOURCEDESC)
!
!                 SPECIFICATIONS OF ROUTINES REFERENCEDBELOW
!
!
%EXTERNALROUTINESPEC NDIAG(%INTEGER AP,%HALFINTEGER I,J,K)
%EXTERNALROUTINESPEC CLOSE FILES
%EXTERNALREALFNSPEC FLOATLONG(%INTEGER VAL)
%EXTERNALINTEGERFNSPEC TRUNCLONG(%REAL VAL)
!
!
%EXTERNALINTEGERFN F77 IABS(%INTEGERNAME I,%INTEGER K)
      %IF I<0 %THEN %RESULT=-I %ELSE %RESULT=I
%END
%EXTERNALREALFN F77 ABS(%REALNAME X,%INTEGER I)
      %IF X<0 %THEN %RESULT=-X %ELSE %RESULT=X
%END
%EXTERNALINTEGERFN F77 MOD(%INTEGERNAME I,%INTEGER II,
                   %INTEGERNAME J,%INTEGER JJ)
      %INTEGER K
      K=I//J
      K=K*J
      %RESULT=I-K
%END
%EXTERNALREALFN F77 AMOD(%REALNAME X,%INTEGER II,
                  %REALNAME Y,%INTEGER J)
%HALFINTEGER I
      I=TRUNCLONG(X/Y)
      %RESULT=X-FLOATLONG(I)*Y
%END
%EXTERNALINTEGERFN F77 ISIGN(%INTEGERNAME I,%INTEGER II,
                   %INTEGERNAME J,%INTEGER JJ)
%INTEGER K
      %IF J<0 %THEN K=-1 %ELSE K=1
      %IF I<0 %THEN %RESULT=-I*K %ELSE %RESULT=I*K
%END
%EXTERNALREALFN F77 SIGN (%REALNAME X,%INTEGER II,
                   %REALNAME Y,%INTEGER J)
%REAL I
      %IF Y<0.0 %THEN I=-1.0 %ELSE I=1.0
      %IF X<0 %THEN %RESULT=-X*I %ELSE %RESULT=X*I
%END
%EXTERNALINTEGERFN F77 NINT(%REALNAME X,%INTEGER II)
%REAL Y,REM
%INTEGER K
%HALFINTEGER I
       %IF X<0 %THEN Y=-X %AND K=-1 %ELSE Y=X %AND K=1
      I=TRUNCLONG(Y)
      REM=Y-FLOATLONG(I)
      %IF REM>=0.5 %THEN %RESULT=(I+1)*K %ELSE %RESULT=I*K
%END
%EXTERNALREALFN F77 AINT(%REALNAME X,%INTEGER II)
%REAL Y,I
%IF X<0 %THEN Y=-X %AND I=-1.0 %ELSE Y=X %AND I=1.0
   %IF Y<1.0 %THEN %RESULT=0.0  %ELSE %RESULT=FLOATLONG(TRUNCLONG(Y)*I)
%END
%EXTERNALREALFN F77 ANINT(%REALNAME X,%INTEGER II)
%REAL Y,REM,K
%HALFINTEGER I
      %IF X<0 %THEN Y=-X %AND K=-1.0 %ELSE Y=X %AND K=1.0
      I=TRUNCLONG(X)
      REM=Y-FLOATLONG(I)
      %IF REM>=0.5 %THEN %RESULT=FLOATLONG((I+1)*K) %ELSEC 
%RESULT=FLOATLONG(I*K)
%END
%EXTERNALINTEGERFN F77 IDIM(%INTEGERNAME I,%INTEGER II,
                  %INTEGERNAME J,%INTEGER JJ)
      %IF I>J %THEN %RESULT=I-J %ELSE %RESULT=0
%END
%EXTERNALREALFN F77 DIM(%REALNAME X,%INTEGER II,
                       %REALNAME Y,%INTEGER JJ)
      %IF X>Y %THEN %RESULT=X-Y %ELSE %RESULT=0.0
%END
%ROUTINE COPY(%INTEGER LEN,SBASE,%HALFINTEGER SDISP,
                  %INTEGER TBASE,%HALFINTEGER TDISP)
      **@TBASE; *LDDW; **TDISP
      **@SBASE; *LDDW; **SDISP
      **LEN+1
      *STLATE_X'63'; *MVBW
%END
%EXTERNALINTEGERFN F77 LLE(%INTEGER A0,%HALFINTEGER D0,L0,
%INTEGER LL0,A1,%HALFINTEGER D1,L1,%INTEGER LL1)
      %RESULT=F77 CHREL(5,A0,D0,L0,A1,D1,L1)
%END
%EXTERNALINTEGERFN F77 LGT(%INTEGER A0,%HALFINTEGER D0,L0,
%INTEGER LL0,A1,%HALFINTEGER D1,L1,%INTEGER LL1)
      %RESULT=F77 CHREL(0,A0,D0,L0,A1,D1,L1)
%END
%EXTERNALINTEGERFN F77 LLT(%INTEGER A0,%HALFINTEGER D0,L0,
%INTEGER LL0,A1,%HALFINTEGER D1,L1,%INTEGER LL1)
      %RESULT=F77 CHREL(1,A0,D0,L0,A1,D1,L1)
%END
%EXTERNALINTEGERFN F77 LGE(%INTEGER A0,%HALFINTEGER D0,L0,
%INTEGER LL0,A1,%HALFINTEGER D1,L1,%INTEGER LL1)
     %RESULT=F77 CHREL(4,A0,D0,L0,A1,D1,L1)
%END
!
%EXTERNALINTEGERFN F77 LEN (%INTEGER A0,%HALFINTEGER D0, L0,
                 %INTEGER LL0)
   %RESULT = L0
%END
!
%INTEGERFN COMPARE (    %INTEGER LENGTH, THIS BASE ,
                    %HALFINTEGER         THIS DISP ,
                        %INTEGER         THAT BASE ,
                    %HALFINTEGER         THAT DISP )
!
!
!
!
!     A Utility Procedure to lexographically compare two texts
!
!            of equal length and to return a value which
!
!            represents the result of the comparision.
!
!
!     At Exit:  RESULT=  0 if Text(THIS BASE)=Text(THAT BASE) or LENGTH<=0
!               RESULT= 2 if Text(THIS BASE)<Text(THAT BASE)
!               RESULT=  1 if Text(THIS BASE)>Text(THAT BASE)
!
!
!
%HALFINTEGER BOOLEAN
%HALFINTEGER TRUE
      TRUE=0
    !
    !
    **@THAT BASE ;  *LDDW    ;  **THAT DISP
    **@THIS BASE ;  *LDDW    ;  **THIS DISP
    **LENGTH     ;
    *STLATE_X'63';  *EQUBYT_0;  **=BOOLEAN
                               %UNLESS BOOLEAN=TRUE %THENRESULT= 0 {equal}

    **@THAT BASE ;  *LDDW    ;  **THAT DISP
    **@THIS BASE ;  *LDDW    ;  **THIS DISP
    **LENGTH     ;
    *STLATE_X'63';  *LESBYT_0;  **=BOOLEAN
                               %IF BOOLEAN=TRUE %THENRESULT=2 {   less than}
                                                    %RESULT= 1 {greater than}
%END; !of COMPARE
%EXTERNALINTEGERFN F77 INDEX (%INTEGER SEARCHBASE,
%HALFINTEGER SEARCHDISP,SEARCHLEN,%INTEGER KEYBASE,%HALFINTEGER KEYDISP,
KEYLEN)
%HALFINTEGER I,RES,TARGET
%BYTEINTEGERARRAYNAME STR,SUBSTR
%BYTEINTEGERARRAYFORMAT STRF(0:4000),SUBSTRF(0:4000)
      STR==ARRAY(SEARCHBASE,STRF)
      SUBSTR==ARRAY(KEYBASE,SUBSTRF)
      %IF KEYLEN>SEARCHLEN %THEN %RESULT=0
      %IF KEYLEN <=0 %OR SEARCHLEN <=0 %THEN %RESULT=0
      TARGET=SUBSTR(KEYDISP)
      %CYCLE I=0,1,SEARCHLEN-1
         %IF STR(SEARCHDISP+I)=TARGET %THEN %START
            %IF SEARCHLEN-I<KEYLEN %THEN %RESULT=0
            RES=COMPARE(KEYLEN,KEYBASE,KEYDISP,SEARCHBASE,SEARCHDISP+I)
            %IF RES=0 %THEN %RESULT=I+1
         %FINISH
      %REPEAT
      %RESULT=0   ;!  SUBSTRING NOT FOUND
%END
%ROUTINE FILL(%INTEGER AD,%HALFINTEGER DISP,LEN)
      %WHILE LEN>0 %CYCLE
      *LDL1
      *LDL0

      **DISP
      *LDCB_X'20'
      *TLATE3
      *STB
      DISP=DISP+1
      LEN=LEN-1
      %REPEAT
%END
%ROUTINE DESCTOSTR(%INTEGER VAL,%STRINGNAME S)
%INTEGER LEN,DISP
      LEN=HALFINTEGER(VAL+3)
      LEN=32 %IF LEN>32
      DISP=HALFINTEGER(VAL+2)
      COPY(LEN,INTEGER(VAL),DISP,ADDR(S),1)
      LENGTH(S)=LEN
%END
%EXTERNALHALFINTEGERFN F77 CONCAT(%INTEGER OUTPUTBASE,
      %HALFINTEGER OUTPUT DISP,OUTPUT LEN,%INTEGER COUNT,
ADDRINPUTDESCS,%HALFINTEGER SPACEFILL)
%INTEGER I,LEN,OUTPUTPTR,ADR,DISP,SETEXIT,PARAMADR
!    0   DONT SPACEFILL
!    1 SPACEFILL
      SETEXIT=0
      OUTPUTPTR=OUTPUTDISP
      %CYCLE I=0,2,(COUNT-1)*2
         PARAMADR=INTEGER(ADDR INPUT DESCS+I)
         LEN=HALFINTEGER(PARAMADR+3)
         %IF OUTPUTLEN>LEN %THEN OUTPUTLEN=OUTPUTLEN-LEN %ELSEC
                  LEN=OUTPUTLEN %AND SETEXIT=1
         ADR=INTEGER(PARAMADR)
         DISP=HALFINTEGER(PARAM ADR+2)
         COPY(LEN,ADR,DISP,OUTPUTBASE,OUTPUTPTR)
         %IF SETEXIT=1 %THEN %RESULT=OUTPUTLEN
         OUTPUTPTR=OUTPUTPTR+LEN
      %REPEAT
      %IF OUTPUTLEN>0 %AND SPACEFILL=1 %THENC 
      FILL(OUTPUTBASE,OUTPUTPTR,OUTPUTLEN) %AND %RESULT=OUTPUTLEN %ELSEC
         %RESULT=OUTPUTPTR-OUTPUT DISP

%END; !OF F77 CONCAT
%EXTERNALROUTINE F77 IOERR(%HALFINTEGER ERRNO)
%HALFINTEGER AP
      *LSSN
      *LDAP
      *TLATE1
      *LDIND
      **=AP
      NDIAG(AP,0,0,1)
%END; !OF F77 IOERR
%EXTERNALROUTINE F77 RTERR(%HALFINTEGER ERRNO)
%HALFINTEGER AP
      *LDAP
      **=AP
      NDIAG(AP,0,ERRNO,1)
%END; !OF F77 RTERR
%EXTERNALROUTINE F77 STOP(%HALFINTEGER PTYPE,%INTEGER VAL)
%STRING(32) S
!  PTYPE = 0 STOP
!  PTYPE = 1 STOP <INT>
!  PTYPE = 2 STOP <STRING>
      CLOSE FILES
      NEWLINE
      %IF PTYPE#0 %THEN PRINTSTRING(" FORTRAN STOP")
      %IF PTYPE=1 %THEN WRITE(INTEGER(VAL),4)
      %IF PTYPE=2 %THEN DESCTOSTR(VAL,S) %AND PRINTSTRING(" ".S)
      NEWLINE
     %STOP
%END
%EXTERNALROUTINE F77 PAUSE (%HALFINTEGER PTYPE,%INTEGER VAL)
%STRING(32) S
! PTYPE=0 PAUSE
! PTYPE=1 PAUSE <INT>
! PTYPE=2 PAUSE <STRING>
      PRINTSTRING(" FORTRAN PAUSE")
      %IF PTYPE=1 %THEN WRITE(INTEGER(VAL),4)
      %IF PTYPE=2 %THEN DESCTOSTR(VAL,S) %AND PRINTSTRING(" ".S)
      NEWLINE
%END
%EXTERNALROUTINE F77COPY (%INTEGER TARGET BASE,%HALFINTEGER TARGET DISP,
TARGET LEN,%INTEGER SOURCE BASE,%HALFINTEGER SOURCE DISP,SOURCE LEN)
%HALFINTEGER I
      I=HALFINTEGER(SOURCEBASE+SOURCEDISP>>1)
      %IF SOURCEDISP&1 =0 %THEN I=I&X'FF' %ELSE I=I>>8
      %IF I=X'80' %THEN F77 RTERR(401)
      %IF TARGET LEN<=SOURCE LEN %THEN SOURCE LEN=TARGET LEN
      COPY(SOURCE LEN,SOURCE BASE,SOURCE DISP,TARGET BASE,TARGET DISP)
      %IF TARGET LEN>SOURCE LEN %THEN  %C
      FILL(TARGET BASE,TARGET DISP+SOURCE LEN,TARGET LEN-SOURCE LEN)
%END
%EXTERNALROUTINE F77 CMULTC(%INTEGER AD,%REAL R1,C1,R2,C2)
%REAL R3,C3
      R3=R1*R2-C1*C2
      C3=C1*R2+C2*R1
      REAL(AD)=R3
      REAL(AD+2)=C3
!      **AD+1
!      **AD
!      **@R3
!      *TLATE2
!      *MOVB_4
%END
%EXTERNALROUTINE F77 CDIVC(%INTEGER AD,%REAL R1,C1,R2,C2)
%REAL R,R3,C3
      R=R2*R2+C2*C2
      R3=(R1*R2+C1*C2)/R
      C3=(C1*R2-R1*C2)/R
      REAL(AD)=R3
REAL(AD+2)=C3
!      **AD+1
!      **AD
!      **@R3
!      *TLATE2
!      *MOVB_4
%END
%EXTERNALINTEGERFN F77 CXREL(%REAL R1,C1,R2,C2)
!    1-TRUE,0  FALSE
      %IF R1=R2 %AND C1=C2 %THEN %RESULT=1 %ELSE %RESULT=0
%END
%INTEGERFN BALANCE(%HALFINTEGER LEN,NO,%INTEGER BASE,%HALFINTEGER DISP)
%HALFINTEGER I
%BYTEINTEGERARRAYNAME BYTE
%BYTEINTEGERARRAYFORMAT BYTEF(0:4000)
      BYTE==ARRAY(BASE,BYTEF)
      %CYCLE I=LEN,1,NO
         %IF BYTE(DISP+I)#X'20' %THEN %RESULT=1;! #space
      %REPEAT
      %RESULT=0   ;! = a space
%END
%EXTERNALINTEGERFN F77 CHREL(%HALFINTEGER OP,%INTEGER LBASE,
   %HALFINTEGER LDISP,LLEN,%INTEGER RBASE,
   %HALFINTEGER RDISP,RLEN)
!  OP=0  GT
!  OP=1  LT
!  OP=2  NE
!  OP=3  EQ
!  OP=4  GE
!  OP=5  LE
! TRUE=RESULT 1
! FALSE=RESULT 0
%HALFINTEGER I,TRUE,FALSE,LEN,LT,GT,EQ
%INTEGER RES
%SWITCH SW(0:5)
!
!
      EQ=0
      GT=1
      LT=2
      TRUE=1
      FALSE=0
      %IF LLEN>RLEN %THEN LEN=RLEN %ELSE LEN=LLEN
      RES=COMPARE(LEN,LBASE,LDISP,RBASE,RDISP)
      ->SW(OP)
!
!
SW(0): !LGT
      %IF RES=LT %OR (RES=EQ %AND RLEN=LLEN) %THEN %RESULT=FALSE
      %IF RES=GT %THEN %RESULT=TRUE
      %IF LLEN>RLEN %THENSTART
         RES=BALANCE(LEN,LLEN-1,LBASE,LDISP)
      %IF RES=1 %THEN %RESULT=TRUE %ELSE %RESULT=FALSE
      %FINISHELSE %RESULT=FALSE
!
!
SW(1):  !LLT
      %IF RES=GT %OR (RES=EQ %AND RLEN=LLEN) %THEN %RESULT=FALSE
      %IF  RES=LT %THEN %RESULT=TRUE
      %IF RLEN>LLEN %THENSTART
         RES=BALANCE(LEN,RLEN-1,RBASE,RDISP)
         %IF RES=1 %THEN %RESULT=TRUE %ELSE %RESULT=FALSE
      %FINISHELSE %RESULT=FALSE
!
!
SW(2):  !NE
      %IF RES#EQ %THEN %RESULT=TRUE
      %IF RLEN=LLEN %THEN %RESULT=FALSE
      %IF LLEN>RLEN %THEN RES=BALANCE(LEN,LLEN-1,LBASE,LDISP) %ELSEC
                              RES=BALANCE(LEN,RLEN-1,RBASE,RDISP)
      %IF RES=1 %THEN %RESULT=TRUE %ELSE %RESULT=FALSE
!
!
SW(3):  !EQ
      %IF RES#EQ %THEN %RESULT=FALSE
      %IF RLEN=LLEN  %THEN %RESULT=TRUE
      %IF LLEN>RLEN %THEN RES=BALANCE(LEN,LLEN-1,LBASE,LDISP) %ELSEC
                              RES=BALANCE(LEN,RLEN-1,RBASE,RDISP)
      %IF RES=0 %THEN %RESULT=TRUE %ELSE %RESULT=FALSE
!
!
SW(4): !LGE
      %IF RES=LT %THEN %RESULT=FALSE
      %IF RES=GT %THEN %RESULT=TRUE
      %IF LLEN>=RLEN %THEN %RESULT=TRUE
      RES=BALANCE(LEN,RLEN-1,RBASE,RDISP)
      %IF RES=0 %THEN %RESULT=TRUE %ELSE %RESULT=FALSE
!
!
SW(5):  !LLE
      %IF RES=LT %THEN %RESULT=TRUE
      %IF RES=GT %THEN %RESULT=FALSE
      %IF LLEN<=RLEN %THEN %RESULT=TRUE
      RES=BALANCE(LEN,LLEN-1,LBASE,LDISP)
      %IF RES=0 %THEN %RESULT=TRUE %ELSE %RESULT=FALSE
%END
%EXTERNALROUTINE F77 PCHAR(%INTEGER ADDRTARGETDESC,ADDR SOURCE DESC)
%HALFINTEGER LEN,SOURCEDISP,TARGETDISP,I,LENT,J
%INTEGER AD
!  IF LENGTH OF SOURCE =-1 THEN SOURCE IS A PASCAL STRING
! WITH LENGTH IN THE FIRST BYTE
      I=1
      LEN=HALFINTEGER(ADDR SOURCE DESC+3)
      LEN=255 %IF LEN>255
      %IF LEN=-1 %THENSTART;   ! THEN COPY BACK
         AD=INTEGER(ADDR SOURCE DESC)
         LEN=HALFINTEGER(AD)&X'00FF'
         HALFINTEGER(ADDR SOURCE DESC+3)=LEN
         I=0
      %FINISH
      SOURCE DISP=HALFINTEGER(ADDR SOURCE DESC+2)
      TARGET DISP=HALFINTEGER(ADDR TARGET DESC+2)
      %IF I=0 %THEN J=1 %ELSE J=0
      COPY(LEN,INTEGER(ADDRSOURCE DESC),SOURCEDISP+J,
          INTEGER(ADDR TARGET DESC),TARGETDISP+I)
      %IF I=0 %THENSTART
         LENT=HALFINTEGER(ADDR TARGET DESC+3)
         %IF LENT>LEN %THENC
         FILL(INTEGER(ADDRTARGETDESC),TARGETDISP+LEN,LENT-LEN)
      %FINISHELSESTART
      AD=INTEGER(ADDR TARGET DESC)
      HALFINTEGER(AD)=(HALFINTEGER(AD)&X'FF00')!LEN
      %FINISH
%END
%ENDOFFILE