(*==========================================================================*)
(*                                                                          *)
(*  PASCAL-XSC - MODUL  SERVICE                                     990626  *)
(*                                                                          *)
(*  (c) Markus Neher    Institute for Applied Mathematics                   *)
(*                      D-76128 Karlsruhe University, Germany               *)
(*                      e-mail: markus.neher@math.uni-karlsruhe.de          *)
(*                                                                          *)
(*  CLOSING GAPS IN ORDINARY PASCAL-XSC                                     *)
(*                                                                          *)
(*==========================================================================*)

MODULE service;
                                                                              
(*  The ultimate PASCAL-XSC service routines                                *)

USE i_ari , mv_ari , mvi_ari;
 
(*--------------------------------------------------------------------------*)
(*                                                                          *)
(*  Part I :  Nice arithmetic operators and basic functions                 *)
(*            missing in ordinary PASCAL-XSC                                *)
(*                                                                          *)
(*--------------------------------------------------------------------------*)

GLOBAL OPERATOR ** ( I , J : INTEGER ) RES : INTEGER;
   
VAR K , ERG : INTEGER;
    ERR     : REAL;

BEGIN IF J < 0 THEN
         ERR := 1 / 0   
      ELSE BEGIN
         ERG := 1;
         FOR K := 1 TO J DO
             ERG := ERG * I;
      END; 
      RES := ERG;
END; 
 
(*--------------------------------------------------------------------------*)

GLOBAL OPERATOR ** ( R : REAL ; J : INTEGER ) RES : REAL;
   
VAR K   : INTEGER;
    ERG : REAL;

BEGIN IF J < 0 THEN
         ERG := 1 / 0   
      ELSE BEGIN
         ERG := 1;
         FOR K := 1 TO J DO
             ERG := ERG * R;
      END; 
      RES := ERG;
END; 

(*--------------------------------------------------------------------------*)

GLOBAL OPERATOR ** ( R : REAL ; S : REAL ) RES : REAL;
   
VAR ERG : REAL;

BEGIN IF R <= 0 THEN
         ERG := 1 / 0   
      ELSE
         ERG := EXP( S * LN( R ) );
      RES := ERG;
END; 

(*--------------------------------------------------------------------------*)

GLOBAL OPERATOR ** ( IX : INTERVAL; J : INTEGER ) RES : INTERVAL;
 
VAR K    : INTEGER;
    IERG : INTERVAL;
     
BEGIN IF J < 0 THEN
         IERG.INF := 1 / 0
      ELSE
         IF ( IX.INF >= 0 ) OR ( IX.SUP <= 0 ) THEN BEGIN
            IERG := 1;
            FOR K := 1 TO J DO
                IERG := IERG * IX;
            END 
         ELSE
            IF J MOD 2 = 0 THEN BEGIN
               IERG := 1;
               FOR K := 1 TO J DIV 2 DO
                   IERG := IERG * SQR( IX );
               END 
            ELSE
               IERG := INTVAL( IX.INF , 0 ) ** J + INTVAL( 0 , IX.SUP ) ** J;

      RES := IERG;

END;  

(*--------------------------------------------------------------------------*)

GLOBAL FUNCTION FAC( I : INTEGER ) : INTEGER;
 
VAR K , ERG : INTEGER;
     
BEGIN
   IF I < 0 THEN
      ERG := 1 DIV 0
   ELSE BEGIN
      ERG := 1;
      FOR K := 2 TO I DO
          ERG := ERG * K;
   END;
   FAC := ERG;
END;  

(*--------------------------------------------------------------------------*)

GLOBAL FUNCTION MAX( I , J : INTEGER ) : INTEGER;
 
VAR ERG : INTEGER;
     
BEGIN
   ERG := I;
   IF I < J THEN
      ERG := J;
   MAX := ERG;
END;  

(*--------------------------------------------------------------------------*)

GLOBAL FUNCTION MIN( I , J : INTEGER ) : INTEGER;
 
VAR ERG : INTEGER;
     
BEGIN
   ERG := I;
   IF I > J THEN
      ERG := J;
   MIN := ERG;
END;  

(*--------------------------------------------------------------------------*)

GLOBAL FUNCTION MAX( X , Y : REAL ) : REAL;
 
VAR ERG : REAL;
     
BEGIN
   ERG := X;
   IF X < Y THEN
      ERG := Y;
   MAX := ERG;
END;  

(*--------------------------------------------------------------------------*)

GLOBAL FUNCTION MIN( X , Y : REAL ) : REAL;
 
VAR ERG : REAL;
     
BEGIN
   ERG := X;
   IF X > Y THEN
      ERG := Y;
   MIN := ERG;
END;  

(*--------------------------------------------------------------------------*)
(*                                                                          *)
(*  Part II :  Handy routines for legible output                            *)
(*                                                                          *)
(*--------------------------------------------------------------------------*)

GLOBAL PROCEDURE WRITEPG;
 
(*  SEITENVORSCHUBZEICHEN DRUCKEN  *)

BEGIN
   WRITE( CHR( 12 ) );
END;

(*--------------------------------------------------------------------------*)

GLOBAL PROCEDURE WRITEPG( VAR AUS : TEXT );
 
(*  SEITENVORSCHUBZEICHEN DRUCKEN  *)

BEGIN
   WRITE( AUS , CHR( 12 ) );
END;

(*--------------------------------------------------------------------------*)

GLOBAL PROCEDURE IWRITE( INTER : INTERVAL );
 
BEGIN
   WRITE( '[ ', INTER.INF: 23: 0 : -1,' , ',INTER.SUP: 23: 0 : 1, ' ]' );
END;

(*--------------------------------------------------------------------------*)

GLOBAL PROCEDURE IWRITE( VAR AUS : TEXT; INTER : INTERVAL );
 
BEGIN
   WRITE( AUS, '[ ', INTER.INF: 23: 0 : -1,' , ',INTER.SUP: 23: 0 : 1, ' ]' );
END;

(*--------------------------------------------------------------------------*)

GLOBAL PROCEDURE IWRITELN( INTER : INTERVAL );
 
BEGIN
   WRITE( '[ ', INTER.INF: 23: 0 : -1,' , ',INTER.SUP: 23: 0 : 1, ' ]' );
   WRITELN;
END;

(*--------------------------------------------------------------------------*)

GLOBAL PROCEDURE IWRITELN( VAR AUS : TEXT; INTER : INTERVAL );
 
BEGIN
   WRITE( AUS, '[ ', INTER.INF: 23: 0 : -1,' , ',INTER.SUP: 23: 0 : 1, ' ]' );
   WRITELN( AUS );
END;

(*--------------------------------------------------------------------------*)

GLOBAL PROCEDURE VRWRITE( VAR AUS : TEXT; NAME : STRING; VRX : RVECTOR );
 
VAR I : INTEGER;
 
BEGIN FOR I := LB( VRX ) TO UB( VRX ) DO BEGIN
          IF ( LB( VRX ) >= 0 ) AND ( UB( VRX ) < 10 ) THEN
             WRITE( AUS , NAME , '[' , I : 1 , '] = ' )
          ELSE
             WRITE( AUS , NAME , '[' , I : 2 , '] = ' );
          WRITELN( AUS , VRX[I] );
      END;
      WRITELN( AUS );
END;

(*--------------------------------------------------------------------------*)

GLOBAL PROCEDURE MRWRITE( VAR AUS : TEXT; NAME : STRING; MRA : RMATRIX );
 
(*  SPALTENWEISE AUSGABE DER MATRIX MRA  *)
 
VAR I , J : INTEGER;
 
BEGIN FOR J := LB( MRA , 2 ) TO UB( MRA , 2 ) DO BEGIN
          FOR I := LB( MRA ) TO UB( MRA ) DO BEGIN

              IF ( LB( MRA ) >= 0 ) AND ( UB( MRA ) < 10 ) THEN
                 WRITE( AUS , NAME , '[' , I : 1 , ',' )
              ELSE
                 WRITE( AUS , NAME , '[' , I : 2 , ',' );

              IF ( LB( MRA , 2 ) >= 0 ) AND ( UB( MRA , 2 ) < 10 ) THEN
                 WRITE( AUS , J : 1 , '] = ' )
              ELSE
                 WRITE( AUS , J : 2 , '] = ' );

              WRITELN( AUS , MRA[I,J] );
          END;
          WRITELN( AUS );
      END;
END;

(*--------------------------------------------------------------------------*)

GLOBAL PROCEDURE VIWRITE( VAR AUS : TEXT; NAME : STRING; VIX : IVECTOR );
 
VAR I : INTEGER;
 
BEGIN FOR I := LB( VIX ) TO UB( VIX ) DO BEGIN
          IF ( LB( VIX ) >= 0 ) AND ( UB( VIX ) < 10 ) THEN
             WRITE( AUS , NAME , '[' , I : 1 , '] = ' )
          ELSE
             WRITE( AUS , NAME , '[' , I : 2 , '] = ' );
          IWRITE( AUS , VIX[I] );
          WRITELN( AUS );
      END;
      WRITELN( AUS );
END;

(*--------------------------------------------------------------------------*)

GLOBAL PROCEDURE MIWRITE( VAR AUS : TEXT; NAME : STRING; MIA : IMATRIX );
 
(*  SPALTENWEISE AUSGABE DER MATRIX MIA  *)
 
VAR I , J : INTEGER;
 
BEGIN FOR J := LB( MIA , 2 ) TO UB( MIA , 2 ) DO BEGIN
          FOR I := LB( MIA ) TO UB( MIA ) DO BEGIN

              IF ( LB( MIA ) >= 0 ) AND ( UB( MIA ) < 10 ) THEN
                 WRITE( AUS , NAME , '[' , I : 1 , ',' )
              ELSE
                 WRITE( AUS , NAME , '[' , I : 2 , ',' );

              IF ( LB( MIA , 2 ) >= 0 ) AND ( UB( MIA , 2 ) < 10 ) THEN
                 WRITE( AUS , J : 1 , '] = ' )
              ELSE
                 WRITE( AUS , J : 2 , '] = ' );

              IWRITE( AUS , MIA[I,J] );
              WRITELN( AUS );
          END;
          WRITELN( AUS );
      END;
END;


(*--------------------------------------------------------------------------*)

END.

(*==========================================================================*)
(*                                                                          *)
(*  PASCAL-XSC - MODULE  SERVICE                                            *)
(*                                                                          *)
(*  CLOSING GAPS IN ORDINARY PASCAL-XSC                                     *)
(*                                                                          *)
(*==========================================================================*)