! 04/11/86 - correction to COMPARE
! 17/07/86 - corrections to LGT etc fns
!*
%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 A1,A2,L1,L2)
{ 5} %integerfnspec Fcpstr(%integer Relop,A1,A2,L1,L2)
{ 6} %routinespec Fconcat %alias "f_concat"(%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 L0,A0,L1,A1)
{37} %integerfnspec F77 LGT {%alias "f_lgt"} (%integer L0,A0,L1,A1)
{38} %integerfnspec F77 LLE {%alias "f_lle"} (%integer L0,A0,L1,A1)
{39} %integerfnspec F77 LLT {%alias "f_llt"} (%integer L0,A0,L1,A1)
{40} %routinespec Fpcheck
!*
!***********************************************************************
!*
%externalroutinespec Ndiag %alias "s#ndiag"(%integer i,j,k,l)
{%externalroutinespec Close Files}
!%externalroutinespec Copy(%integer Len,Sbase,Soffset,Tbase,Toffset)
!*
!%externalinteger Ioerror
!*
!***********************************************************************
!*
!*
%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 F77 Stop %alias "f_stop"(%integer Ptype,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=0 %then write(Val,4)
%if Ptype>0 %then Desctostr(Val,Ptype,S) %and printstring(" ".S)
newline
%stop
%end;! F77 Stop
!*
%externalroutine F77 Pause %alias "f_pause"(%integer PTYPE,VAL)
%string(32) S
! PTYPE=0 PAUSE
! PTYPE=1 PAUSE <INT>
! PTYPE=2 PAUSE <STRING>
newline
printstring(" FORTRAN PAUSE")
%if Ptype=0 %then write(Val,4)
%if Ptype>0 %then Desctostr(Val,Ptype,S) %and printstring(" ".S)
newline
{ WAIT }
%end;! F77 Pause
!*
!!%externalroutine F77 Ioerr(%shortinteger Errno)
!!%shortinteger Ap
!! *LSSN
!! *LDAP
!! *TLATE1
!! *LDIND
!! **=AP
!! NDIAG(AP,0,0,1)
!!%end; ! F77 Ioerr
!*
%externalroutine F77RTERR %alias "f_rterr" (%integer err,
line no, adr of procedure name)
!
!
%conststring(52) %array error messages ( 401: 418)= %c
%c
"Unassigned variable" , {Fault 401}
"Adjustable dimension bound is unassigned" , {Fault 402}
"Assigned value is invalid" , {Fault 403}
"Assigned label is not in specified list" , {Fault 404}
"Integer is not assigned with a format label" , {Fault 405}
"Array bounds exceeded" , {Fault 406}
"Array parameter upper bound is less than lower bound" , {Fault 407}
"Array parameter declared size is greater than actual" , {Fault 408}
"Assumed size array requires zero last dimension" , {Fault 409}
"no text" , {Fault 410}
"Invalid character substring position value" , {Fault 411}
"Character param declared size greater than actual" , {Fault 412}
"no text" , {Fault 413}
"no text" , {Fault 414}
"DO loop increment is zero" , {Fault 415}
"no text" , {Fault 416}
"no text" , {Fault 417}
"Recursive call to a procedure" {Fault 418}
%integer R10
->skip
!Print the Error Message:
!
!
print string ("
Run-Time Error"); write(err,3); print string (": ");
%if err>= 401 %and %c
err<= 418 %then print string (error messages (err)) %c
%else print string ("no text")
print string ("
In Procedure:"); print string (string(adr of procedure name))
print string ("
At Line :") %and write (line no,1) %if line no>0
newline
skip:
!Now Stop With Diagnostics:
!
*ST_10,R10
Ndiag(0,integer(R10+40),Err,0)
%stop
%end; !of F77RTERR
!*
%routine Fpcheck
%end
!*
%routine Fcpystr %alias "f_cpystr" (%integer A1, A2, L1, L2)
!* A1,D1 source
!* A2,D2 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 Relop,A1,A2,L1,L2)
!***********************************************************************
!* Relop = 0 GT 1 LT 2 NE 3 EQ 4 GE 5 LE *
!***********************************************************************
%integer C1,C2,I,L
%constbyteintegerarray Eqres(0:5)=0,0,0,1,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(2): ! NE
%result=1
C(3): ! 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(Fromad,Ad,Fromlen,Actlen)
Ad=Ad+Actlen
Len=Len-Actlen
%finishelse %return
%repeat
%end;! Fconcat
!*
%externalintegerfn Fibits(%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 Fishftc(%integer a1,a2)
!* cyclic shift of a1 by a2
%integer i,j,k,m1,m2
a2=a2&31
%result=(a1<<a2)!(a1>>(32-a2))
! %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 L0,A0,L1,A1)
%integer I,TRUE,FALSE,LEN,LT,GT,EQ
%integer RES
L0=L0&X'FFFF'
L1=L1&X'FFFF'
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 L0,A0,L1,A1)
%integer I,TRUE,FALSE,LEN,LT,GT,EQ
%integer RES
L0=L0&X'FFFF'
L1=L1&X'FFFF'
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 L0,A0,L1,A1)
%integer I,TRUE,FALSE,LEN,LT,GT,EQ
%integer RES
L0=L0&X'FFFF'
L1=L1&X'FFFF'
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 L0,A0,L1,A1)
%integer I,TRUE,FALSE,LEN,LT,GT,EQ
%integer RES
L0=L0&X'FFFF'
L1=L1&X'FFFF'
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= 2 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= 2 { 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 Searchlen,
Searchbase,Keylen,Keybase)
%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
%byteintegerarrayformat 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