!                                                                f77aux15
! 15/09/87 - insert routines F_ibits, F_ishftc
!                                                                f77aux14
! 02/02/87 - remove routine Fconcat2
!                                                                f77aux13
! 24/02/87 - new routine Fconcat2
! 19/02/87 - corrections to Crmult, Crdiv, Cddiv
!          - replace routines Copy & Fill by system routine s#move &s#fill
!          - include file ftn_ht
! 10/02/87 - correction to Cdmult
!
!                                                                f77aux12
! 04/11/86 - correction to COMPARE
! 17/07/86 - corrections to LGT etc fns
!*
%include "ftn_ht"
!*
%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"} (%record(cxf)%name c)
{33} %routinespec    F77 CONJG {%alias "f_conjg"} (%record(cxf)%name a,b)
{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
!*
!***********************************************************************
!*
!*
%if target=ibm %thenstart
  %externalroutinespec Copy %alias "s#move"(%integer len,from,to)
%finishelsestart
  %routine Copy(%integer L,From,To)
  %integer I
        %cycle I=0,1,L-1
           byteinteger(To+I)=byteinteger(From+I)
        %repeat
  %end;! Copy
%finish
!*
%if target=ibm %thenstart
  %externalroutinespec Fill %alias "s#fill"(%integer len,from,filler)
%finishelsestart
  %routine Fill(%integer L,At,With)
  %integer I
        %cycle I=0,1,L-1
           byteinteger(At+I)=With
        %repeat
  %end;! Fill
%finish
!*
%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 fbits %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 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
!*
%externalintegerfn Fishftc3 %alias "F_ishftc"(%integer a1,a2,a3)
!* cyclic shift of rigthmost a3 bits of a1 by a2
%integer i,j,k,m1,m2
    %if a3<=0 %then %result=a1
    %if a3>32 %then a3=32
    a2=a2-((a2//a3)*a3) ;! modulus of shift
    %if a2<0 %then a2=a3+a2
    %if a3=32 %then %result=(a1<<a2)!(a1>>(32-a2))
      m1=(-1)<<a3      ;! mask for untouched part
      m2=(-1)!!m1      ;! mask for shifted part
      j=a1&m1;! untouched
      i=a1&m2;! to be shifted
      %result=j!(((i<<a2)!(i>>(a3-a2)))&m2)
%end
%externalroutine    Crmult %alias "f_crmult"(%record(cxf)%name c,a,b)
%longreal temp
      temp=a_real*b_real-a_imag*b_imag
      c_imag=a_real*b_imag+a_imag*b_real
      c_real=temp;             ! in case c==a or b
%end
!*
%externalroutine    Cdmult %alias "f_cdmult"(%record(dcxf)%name c,a,b)
%longreal temp
      temp=a_real*b_real-a_imag*b_imag
      c_imag=a_real*b_imag+a_imag*b_real
      c_real=temp;               ! In case c==a or b
%end
!*
%externalroutine    Crdiv %alias "f_crdiv"(%record(cxf)%name c,a,b)
%real ratio, den, abr, abi,creal,cimag
      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)
        creal    = (a_real*ratio + a_imag) / den
        cimag     = (a_imag*ratio - a_real) / den
      %finishelsestart
        ratio = b_imag / b_real
        den   = b_real * (1 + ratio*ratio)
        creal    = (a_real + a_imag*ratio) / den
        cimag    = (a_imag - a_real*ratio) / den
      %finish
      c_real=creal
      c_imag=cimag;                        !in case c==a or b
%end
!*
%externalroutine    Cddiv %alias "f_cddiv"(%record(dcxf)%name c,a,b)
%longreal ratio, den, abr, abi, creal, cimag
      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)
        creal    = (a_real*ratio + a_imag) / den
        cimag    = (a_imag*ratio - a_real) / den
      %finishelsestart
        ratio = b_imag / b_real
        den   = b_real * (1 + ratio*ratio)
        creal    = (a_real + a_imag*ratio) / den
        cimag    = (a_imag - a_real*ratio) / den
      %finish
      c_real=creal
      c_imag=cimag;                        ! in case c==a or b
%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" (%record(cxf)%name c)
      %result=c_imag
%end
!*
%externalroutine F77 CONJG %alias "f_conjg" (%record(cxf)%name a,b)
      a_real=b_real
      a_imag=-b_imag
%end
%endoffile