!* 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