!* modified 27/06/86                                                ftnaux4
!*
%recordformat dcxf(%longreal real,imag)
%recordformat cxf(%real real,imag)
!*
!******************************** exports ******************************
!*
{ 1} %routinespec    F77 Stop(%integer Ptype,%integer Val)
{ 2} %routinespec    F77 Pause (%integer PTYPE,%integer VAL)
{ 3} %routinespec    F77 Rterr(%integer Errno,%integer Line,Addrproc)
{ 4} %routinespec    Fcpystr(%integer A2,L2,A1,L1)
{ 5} %integerfnspec  Fcpstr(%integer Relop,A1,A2,L1,L2)
{ 6} %routinespec    Fconcat(%integer Alist,N,Ad,Len)
{ 7} %integerfnspec  Fibits(%integer a1,a2,a3)
{ 8} %integerfnspec  Fishftc(%integer a1,a2)
{ 9} %routinespec    Crmult(%record(cxf)%name c,a,b)
{10} %routinespec    Cdmult(%record(dcxf)%name c,a,b)
{11} %routinespec    Crdiv(%record(cxf)%name c,a,b)
{12} %routinespec    Cddiv(%record(dcxf)%name c,a,b)
!*
{13} %integerfnspec  F77 IABS  {%alias "f_iabs"}  (%integername I)
{14} %realfnspec     F77 ABS   {%alias "f_abs"}   (%realname X)
{15} %integerfnspec  F77 MOD   {%alias "f_mod"}   (%integername I,J)
{16} %realfnspec     F77 AMOD  {%alias "f_amod"}  (%realname X,Y)
{17} %integerfnspec  F77 ISIGN {%alias "f_isign"} (%integername I,J)
{18} %realfnspec     F77 SIGN  {%alias "f_sign"}  (%realname X,Y)
{19} %integerfnspec  F77 NINT  {%alias "f_nint"}  (%realname X)
{20} %realfnspec     F77 AINT  {%alias "f_aint"}  (%realname X)
{21} %realfnspec     F77 ANINT {%alias "f_anint"} (%realname X)
{22} %integerfnspec  F77 IDIM  {%alias "f_idim"}  (%integername I,J)
{23} %realfnspec     F77 DIM   {%alias "f_dim"}   (%realname X,Y)
{24} %longrealfnspec F77 DINT  {%alias "f_dint"}  (%longrealname X)
{25} %longrealfnspec F77 DNINT {%alias "f_dnint"} (%longrealname X)
{26} %integerfnspec  F77 IDNINT {%alias "f_idnint"} (%longrealname X)
{27} %longrealfnspec F77 DABS  {%alias "f_dabs"}  (%longrealname X)
{28} %longrealfnspec F77 DMOD  {%alias "f_dmod"}  (%longrealname X,Y)
{29} %longrealfnspec F77 DSIGN {%alias "f_dsign"} (%longrealname X,Y)
{30} %longrealfnspec F77 DDIM  {%alias "f_ddim"}  (%longrealname X,Y)
{31} %longrealfnspec F77 DPROD {%alias "f_dprod"} (%realname X,Y)
{32} %realfnspec     F77 AIMAG {%alias "f_aimag"} (%integer ADR)
{33} %routinespec    F77 CONJG {%alias "f_conjg"} (%integer ADR1,ADR)
{34} %integerfnspec  F77 LEN   {%alias "f_len"}   (%integer A0,L0)
{35} %integerfnspec  F77 Index {%alias "f_index"} (%integer Searchlen,
                                              Searchbase,Keylen,Keybase)
{36} %integerfnspec  F77 LGE   {%alias "f_lge"}   (%integer A0,A1,L0,L1)
{37} %integerfnspec  F77 LGT   {%alias "f_lgt"}   (%integer A0,A1,L0,L1)
{38} %integerfnspec  F77 LLE   {%alias "f_lle"}   (%integer A0,A1,L0,L1)
{39} %integerfnspec  F77 LLT   {%alias "f_llt"}   (%integer A0,A1,L0,L1)
!*
!***********************************************************************
!*
!*
%routine Copy(%integer L,From,To)
%integer I
      %cycle I=0,1,L-1
         byteinteger(To+I)=byteinteger(From+I)
      %repeat
%end;! Copy
!*
%routine Fill(%integer L,At,With)
%integer I
      %cycle I=0,1,L-1
         byteinteger(At+I)=With
      %repeat
%end;! Fill
!*
%routine Desctostr(%integer Ad,L,%stringname S)
      L=32 %IF L>32
      Copy(L,Ad,addr(S)+1)
      length(S)=L
%end;! Desctostr
!*
%externalroutine Fcpystr %alias "f_cpystr" (%integer A2, L2,A1, L1)
!* A1,L1  source 
!* A2,L2  dest
%integer I
      %if L2<=L1 %thenstart
         Copy(L2,A1,A2)
         %return
      %finishelsestart
         Copy(L1,A1,A2)
         Fill(L2-L1,A2+L1,' ')
         %return
      %finish
%end;! Fcpystr
!*
%externalintegerfn Fcpstr %alias "f_cpstr" (%integer A1,L1,A2,L2,Relop)
!***********************************************************************
!* Relop = 0  GT   1  LT   2  EQ   3  NE   4  GE   5  LE               *
!***********************************************************************
%integer C1,C2,I,L
%constbyteintegerarray Eqres(0:5)=0,0,1,0,1,1
%switch C(0:5)
{printstring(" cp");write(relop,4);write(l1,4);write(l2,4);newline}
      %if L1<L2 %then L=L1 %else L=L2
      %cycle I=0,1,L-1
         C1=byteinteger(A1+I)
         C2=byteinteger(A2+I)
{printstring(" p1");write(c1,4);write(c2,4);newline}
         %if C1#C2 %then ->C(Relop)
      %repeat
      %if L1=L2 %then %result=Eqres(Relop)
!*
      %if L1<L2 %thenstart
         C1=' '
         A2=A2+L
         %cycle I=0,1,L2-L1-1
            C2=byteinteger(A2+I)
{printstring(" p2");write(c1,4);write(c2,4);newline}
            %if C1#C2 %then ->C(Relop)
         %repeat
         %result=Eqres(Relop)
      %finishelsestart
         C2=' '
         A1=A1+L
         %cycle I=0,1,L1-L2-1
            C1=byteinteger(A1+I)
{printstring(" p3");write(c1,4);write(c2,4);newline}
            %if C1#C2 %then ->C(Relop)
         %repeat
         %result=Eqres(Relop)
      %finish
!*
C(0): ! GT
C(4): ! GE
      %if C1>C2 %then %result=1 %else %result=0
C(1): ! LT
C(5): ! LE
      %if C1>C2 %then %result=0 %else %result=1
C(3): ! NE
      %result=1
C(2): ! EQ
      %result=0
%end;! Fcpstr
!*
%externalroutine Fconcat %alias "f_concat"(%integer Alist,N,Ad,Len)
%integer I,Fromad,Fromlen,Actlen
      %cycle I=1,1,N
         Fromad=integer(Alist)
         Fromlen=integer(Alist+4)
         Alist=Alist+8
         %if Len>0 %thenstart
            %if Len<Fromlen %then Fromlen=Len
            %if I=N %then Actlen=Len %else Actlen=Fromlen;! to space fill
            Fcpystr(Ad,Actlen,Fromad,Fromlen)
            Ad=Ad+Actlen
            Len=Len-Actlen
         %finishelse %return
      %repeat
%end;! Fconcat
!*
%externalintegerfn Fibits %alias "f_ibits"(%integer a1,a2,a3)
!* extract bits a2 to a2+a3-1 from a1 (l.s. bit is 0) 
      a1=a1<<(32-a3-a2)
      %result=a1>>(32-a3)
%end
!*
%externalintegerfn Fibset %alias "f_ibset"(%integer a1,a2)
      %if a2<0 %or a2>31 %then %result=a1
      %result=a1!(1<<a2)
%end
!*
%externalintegerfn Fbtest %alias "f_btest"(%integer a1,a2)
      %if a2<0 %or a2>31 %then %result=0
      %result=(a1>>a2)&1
%end
!*
%externalintegerfn Fibclr %alias "f_ibclr"(%integer a1,a2)
      %if a2<0 %or a2>31 %then %result=a1
      %result=a1&(\(1<<a2))
%end
!*
%externalintegerfn Fishft %alias "f_ishft"(%integer a1,a2)
      %if a2>32 %or a2<-32 %then %result=0
      %if a2>0 %then %result=a1<<a2
      %result=a1>>(-a2)
%end
!*
%externalintegerfn Fishftc %alias "f_ishftc"(%integer a1,a2)
!* cyclic shift of a1 by a2
%integer i,j,k,m1,m2
      a2=a2&31
      %result=(a1<<a2)!(a1>>(32-a2))
%end
!*
%externalintegerfn Fishftc3 %alias "f_ishftc3"(%integer a1,a2,a3)
!* cyclic shift of a1 by a2
%integer i,j,k,m1,m2
      a2=a2&31
      %if a3=32 %and 0<=a2<32 %thenstart
         %result=(a1<<(32-a2))!(a1>>a2)
      %finish
      %if a3>32 %then a3=32
      m1=((-1)>>a2)<<a3;! mask for untouched part
      m2=(-1)!!m1      ;! mask for shifted part
      j=a1&m1;! untouched
      i=a1&m2;! to be shifted
      a2=a2-((a3//a2)*a2);! modulus of shift
      %if a2<0 %then a2=a3+a2
      %result=j!((i<<(32-a2))>>(32-a3))!(i>>a2)
%end
!*
%externalroutine    Crmult %alias "f_crmult"(%record(cxf)%name c,a,b)
      c_real=a_real*b_real-a_imag*b_imag
      c_imag=a_real*b_imag+a_imag*b_real
%end
!*
%externalroutine    Cdmult %alias "f_cdmult"(%record(dcxf)%name c,a,b)
      c_real=a_real*b_real-a_imag*b_imag
      c_imag=a_real*b_imag+a_imag*b_real
%end
!*
%externalroutine    Crdiv %alias "f_crdiv"(%record(cxf)%name c,a,b)
%real ratio, den, abr, abi
      abr = b_real
      %if abr  < 0.0 %then abr = - abr
      abi = b_imag
      %if abi < 0.0 %then abi = - abi
      %if abr <= abi %start
!!        %if abi = 0.0 %then error(100) { complex division by zero } 
        ratio = b_real / b_imag
        den   = b_imag * (1 + ratio*ratio)
        c_real    = (a_real*ratio + a_imag) / den
        c_imag     = (a_imag*ratio - a_real) / den
      %finishelsestart
        ratio = b_imag / b_real
        den   = b_real * (1 + ratio*ratio)
        c_real    = (a_real + a_imag*ratio) / den
        c_imag    = (a_imag - a_real*ratio) / den
      %finish
%end
!*
%externalroutine    Cddiv %alias "f_cddiv"(%record(dcxf)%name c,a,b)
%longreal ratio, den, abr, abi
      abr = b_real
      %if abr  < 0.0 %then abr = - abr
      abi = b_imag
      %if abi < 0.0 %then abi = - abi
      %if abr <= abi %start
!!        %if abi = 0.0 %then error(100) { complex division by zero } 
        ratio = b_real / b_imag
        den   = b_imag * (1 + ratio*ratio)
        c_real    = (a_real*ratio + a_imag) / den
        c_imag    = (a_imag*ratio - a_real) / den
      %finishelsestart
        ratio = b_imag / b_real
        den   = b_real * (1 + ratio*ratio)
        c_real    = (a_real + a_imag*ratio) / den
        c_imag    = (a_imag - a_real*ratio) / den
      %finish
%end
!*
%integerfnspec compare (%integer l,a0,a1)
%integerfnspec balance(%integer l,n,a)
!*
%externalintegerfn F77 IABS %alias "f_iabs" (%integername I)
      %if I<0 %then %result=-I %else %result=I
%end
!*
%externalrealfn F77 ABS %alias "f_abs" (%realname X)
      %if X<0 %then %result=-X %else %result=X
%end
!*
%externalintegerfn F77 MOD %alias "f_mod" (%integername I,J)
%integer K
      K=I//J
      K=K*J
      %result=I-K
%end
!*
%externalrealfn F77 AMOD %alias "f_amod" (%realname X,Y)
%integer SIGN
%real XX,YY
%integer I
      SIGN=1
      XX=X
      YY=Y
      %if X<0 %thenstart
         XX=-X
         %if Y<0 %then YY=-Y %else SIGN=-1
      %finishelse %if Y<0 %then YY=-Y %and SIGN=-1
      I=intpt(XX/YY)
      %result=X-I*SIGN*Y
%end
!*
%externalintegerfn F77 ISIGN %alias "f_isign" (%integername I,J)
%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  %alias "f_sign" (%realname X,Y)
%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 %alias "f_nint" (%realname X)
%real Y,REM
%integer K
%integer I
      %if X<0 %then Y=-X %and K=-1 %else Y=X %and K=1
      I=intpt(Y)
      REM=Y-I
      %if REM>=0.5 %then %result=(I+1)*K %else %result=I*K
%end
!*
%externalrealfn F77 AINT %alias "f_aint" (%realname X)
%real Y
%integer I
      %if X<0 %then Y=-X %and I=-1 %else Y=X %and I=1
      %if Y<1.0 %then %result=0.0 %else %result=intpt(Y)*I
%end
!*
%externalrealfn F77 ANINT %alias "f_anint" (%realname X)
%real Y,REM
%integer K
%integer I
      %if X<0 %then Y=-X %and K=-1 %else Y=X %and K=1
      I=intpt(Y)
      REM=Y-I
      %if REM>=0.5 %then %result=(I+1)*K %elseC 
      %result=I*K
%end
!*
%externalintegerfn F77 IDIM %alias "f_idim" (%integername I,J)
      %if I>J %then %result=I-J %else %result=0
%end
!*
%externalrealfn F77 DIM %alias "f_dim" (%realname X,Y)
      %if X>Y %then %result=X-Y %else %result=0.0
%end
!*
%externalintegerfn F77 LLE %alias "f_lle" (%integer A0,A1,L0,L1)
%integer I,TRUE,FALSE,LEN,LT,GT,EQ
%integer RES
      EQ=0
      GT=1
      LT=2
      TRUE=1
      FALSE=0
      %if L0>L1 %then LEN=L1 %else LEN=L0
      RES=COMPARE(LEN,A0,A1)
      %if RES=LT %then %result=TRUE
      %if RES=GT %then %result=FALSE
      %if L0<=L1 %then %result=TRUE
      RES=BALANCE(LEN,L0-1,A0)
      %if RES=0 %then %result=TRUE %else %result=FALSE
%end
!*
%externalintegerfn F77 LGE %alias "f_lge" (%integer A0,A1,L0,L1)
%integer I,TRUE,FALSE,LEN,LT,GT,EQ
%integer RES
      EQ=0
      GT=1
      LT=2
      TRUE=1
      FALSE=0
      %if L0>L1 %then LEN=L1 %else LEN=L0
      RES=COMPARE(LEN,A0,A1)
      %if RES=LT %then %result=FALSE
      %if RES=GT %then %result=TRUE
      %if L0>=L1 %then %result=TRUE
      RES=BALANCE(LEN,L1-1,A1)
      %if RES=0 %then %result=TRUE %else %result=FALSE
%end
!*
%externalintegerfn F77 LGT %alias "f_lgt" (%integer A0,A1,L0,L1)
%integer I,TRUE,FALSE,LEN,LT,GT,EQ
%integer RES
      EQ=0
      GT=1
      LT=2
      TRUE=1
      FALSE=0
      %if L0>L1 %then LEN=L1 %else LEN=L0
      RES=COMPARE(LEN,A0,A1)
      %if RES=LT %or (RES=EQ %and L1=L0) %then %result=FALSE
      %if RES=GT %then %result=TRUE
      %if L0>L1 %thenstart
         RES=BALANCE(LEN,L0-1,A0)
      %if RES=1 %then %result=TRUE %else %result=FALSE
      %finishelse %result=FALSE
%end
!*
%externalintegerfn F77 LLT %alias "f_llt" (%integer A0,A1,L0,L1)
%integer I,TRUE,FALSE,LEN,LT,GT,EQ
%integer RES
      EQ=0
      GT=1
      LT=2
      TRUE=1
      FALSE=0
      %if L0>L1 %then LEN=L1 %else LEN=L0
      RES=COMPARE(LEN,A0,A1)
      %if RES=GT %or (RES=EQ %and L1=L0) %then %result=FALSE
      %if  RES=LT %then %result=TRUE
      %if L1>L0 %thenstart
         RES=BALANCE(LEN,L1-1,A1)
         %if RES=1 %then %result=TRUE %else %result=FALSE
      %finishelse %result=FALSE
%end
!*
%externalintegerfn F77 LEN  %alias "f_len" (%integer A0,L0)
      %result = L0
%end
!*
%integerfn COMPARE (%integer LENGTH, THIS BASE, 
                                     THAT BASE)
!
!
!     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= -1 if Text(THIS BASE)<Text(THAT BASE)
!               RESULT=  1 if Text(THIS BASE)>Text(THAT BASE)
!
!
%WHILE LENGTH>0 %CYCLE
    !
    %result= 1 {greater than}                                         %C
               %if BYTEINTEGER(THIS BASE)>BYTEINTEGER(THAT BASE)

    %result=-1 {   less than}                                         %C
               %if BYTEINTEGER(THIS BASE)<BYTEINTEGER(THAT BASE)
                               !
                               THIS BASE = THIS BASE + 1
                               THAT BASE = THAT BASE + 1
                                  LENGTH =    LENGTH - 1
    %REPEAT
    !     !
    %result= 0 {  equal to  }
      !
%end; !of COMPARE
!*
%externalintegerfn F77 INDEX  %alias "f_index" (%integer Searchbase,
                                          keybase,searchlen,Keylen)
%integer I,RES,TARGET,J
      Searchlen=Searchlen&X'FFFF'
      Keylen=Keylen&X'FFFF'
      %if KEYLEN>SEARCHLEN %then %result=0
      %if KEYLEN <=0 %or SEARCHLEN <=0 %then %result=0
      TARGET=byteinteger(Keybase)
      %cycle I=0,1,SEARCHLEN-1
         J=byteinteger(Searchbase+I)
         %if J=TARGET %thenstart
            %if KEYLEN=1 %then %result=I+1
            %if SEARCHLEN-I<KEYLEN %then %result=0
            RES=COMPARE(KEYLEN,KEYBASE,SEARCHBASE+I)
            %if RES=0 %then %result=I+1
         %finish
      %repeat
      %result=0   ;!  SUBSTRING NOT FOUND
%end
!*
%integerfn BALANCE(%integer LEN,NO,%integer BASE)
%integer I
%byteintegerarrayname BYTE
%constbyteintegerarrayformat BYTEF(0:4000)
      BYTE==array(BASE,BYTEF)
      %cycle I=LEN,1,NO
         %if BYTE(I)#X'20' %then %result=1;! #space
      %repeat
      %result=0   ;! = a space
%end
!*
%externallongrealfn F77 DINT %alias "f_dint" (%longrealname X)
%longreal Y
%integer I
      %if X<0 %then Y=-X %and I=-1 %else Y=X %and I=1
      %if Y<1 %then %result=0 %else %result=intpt(Y)*I
%end
!*
%externallongrealfn F77 DNINT %alias "f_dnint" (%longrealname X)
%longreal Y,REM
%integer I,K
      %if X<0 %then Y=-X %and K=1 %else Y=X %and K=1
      I=intpt(Y)
      REM=Y-I
      %if REM>=0.5 %then %result=(I+1.0)*K %else %result=I*K
%end
!*
%externalintegerfn F77 IDNINT %alias "f_idnint" (%longrealname X)
%longreal Y,REM
%integer I,K
      %if X<0 %then Y=-X %and K=-1 %else Y=X %and K=1
      I=intpt(Y)
      REM=Y-I
      %if REM>=0.5 %then %result=(I+1)*K %else %result=I*K
%end
!*
%externallongrealfn F77 DABS %alias "f_dabs" (%longrealname X)
      %if X<0 %then %result=-X %else %result=X
%end
!*
%externallongrealfn F77 DMOD %alias "f_dmod" (%longrealname X,Y)
%integer I,SIGN
%longreal XX,YY
      SIGN=1
      XX=X
      YY=Y
      %if X<0 %thenstart
         XX=-X
         %if Y<0 %then YY=-Y %else SIGN=-1
      %finishelse %if Y<0 %then YY=-Y %and SIGN=-1
      I=intpt(XX/YY)
      %result=X-I*SIGN*Y
%end
!*
%externallongrealfn F77 DSIGN %alias "f_dsign" (%longrealname X,Y)
%integer I
      %if Y<0 %then I=-1 %else I=1
      %if X<0 %then %result=-X*I %else %result=X*I
%end
!*
%externallongrealfn F77 DDIM %alias "f_ddim" (%longrealname X,Y)
      %if X>Y %then %result=X-Y %else %result=0
%end
!*
%externallongrealfn F77 DPROD %alias "f_dprod" (%realname X,Y)
%longreal XX,YY
      XX=X
      YY=Y
      %result=XX*YY
%end
!*
%externalrealfn F77 AIMAG %alias "f_aimag" (%integer ADR)
      %result=real(ADR+2)
%end
!*
%externalroutine F77 CONJG %alias "f_conjg" (%integer ADR1,ADR)
      real(ADR1)=real(ADR)
      real(ADR1+2)=-real(ADR+2)
%end
%endoffile