[28b809]: F77func.mod History

Parent: [93da36] (diff)

Download this file

F77func.mod    149 lines (120 with data), 4.8 kB 

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
IMPLEMENTATION MODULE F77func;



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

  (* Funktionen die das Portieren von Fortran-Quellen unterstuetzen.        *)

  (*                                                                        *)

  (* Some Fortran intrinsics which can be used to translate Fortran to M2   *)

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

  (* Letzte Veraenderung:                                                   *)

  (*                                                                        *)

  (* 08.10.15, MRi: Erstellen der 1. Version                                *)

  (* 11.10.15, MRi: MIN0,MAX0 hinzugefuegt.                                 *)

  (* 05.05.16, MRi: Umbenennen von IntrinsicF77 nach F77func, REAL8,        *)

  (*                INTEGER4 eingefuehrt.                                   *)

  (* 28.08.16, MRi: D1Mach hinzugefuegt                                     *)

  (* 08.07.18, MRi: IAND, IOR & IEOR hinzugefuegt                           *)

  (* 01.01.19, MRi: NINT hinzugefuegt                                       *)

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

  (* Offene Punkte:                                                         *)

  (*                                                                        *)

  (* - Erweiterung um andere Funktionen                                     *)

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

  (* Implementation : Michael Riedl                                         *)

  (* Licence        : GNU Lesser General Public License (LGPL)              *)

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



  (* $Id: F77func.mod,v 1.4 2018/07/08 08:41:20 mriedl Exp mriedl $ *)



FROM SYSTEM   IMPORT CAST;

FROM Errors   IMPORT ErrOut,FatalError;

              IMPORT LowLong;

FROM LMathLib IMPORT MachEps;

FROM LongMath IMPORT ln,power;



PROCEDURE DSIGN(a,b : REAL8) : REAL8;



BEGIN

      (* RETURN LowLong.sign(b)*ABS(a); *)

      IF (b >= 0.0) THEN

        RETURN   ABS(a);

      ELSE

        RETURN - ABS(a);

      END;

END DSIGN;



PROCEDURE DMAX(x,y : REAL8) : REAL8;



BEGIN

      IF (x > y) THEN RETURN x ELSE RETURN y; END;

END DMAX;



PROCEDURE DMIN(x,y : REAL8) : REAL8;



BEGIN

      IF (x > y) THEN RETURN y; ELSE RETURN x; END;

END DMIN;



PROCEDURE MIN0(ix,iy : INTEGER4) : INTEGER4;



BEGIN

     IF (ix > iy) THEN RETURN iy ELSE RETURN ix; END;

END MIN0;



PROCEDURE MAX0(ix,iy : INTEGER4) : INTEGER4;



BEGIN

     IF (ix < iy) THEN RETURN iy ELSE RETURN ix; END;

END MAX0;



PROCEDURE DINT(x : REAL8) : REAL8;



BEGIN

      RETURN LowLong.intpart(x); 

END DINT;



PROCEDURE NINT(x : LONGREAL) : INTEGER;



          VAR i : LONGINT;

              r : LONGREAL;

BEGIN

      IF (ABS(x) > LFLOAT(MAX(INTEGER))+0.5) THEN

        FatalError("x > MAX(INTEGER) (NINT)");

        RETURN MAX(INTEGER);

      END;

      IF (ABS(x) < LFLOAT(MIN(INTEGER))-0.5) THEN

        FatalError("x < MIN(INTEGER) (NINT)");

        RETURN MIN(INTEGER);

      END;

      i := INT(TRUNC(ABS(x)));

      IF (x >= 0.0) THEN

        r := x - LFLOAT(i);

        IF (r >= 0.5) THEN INC(i); END;

      ELSE

        r := x + LFLOAT(i);

        IF (r <= -0.5) THEN INC(i); END;

        i := -i;

      END;

      RETURN i;

END NINT;



PROCEDURE IAND(a,b : INTEGER) : INTEGER;



BEGIN

      RETURN VAL(INTEGER,(CAST(BITSET,a) * CAST(BITSET,b)));

END IAND;



PROCEDURE IOR(a,b : INTEGER) : INTEGER;



BEGIN

      RETURN VAL(INTEGER,(CAST(BITSET,a) + CAST(BITSET,b)));

END IOR;



PROCEDURE IEOR(a,b : INTEGER) : INTEGER;



BEGIN

      RETURN VAL(INTEGER,(CAST(BITSET,a) / CAST(BITSET,b)));

END IEOR;



PROCEDURE D1Mach(i : INTEGER): LONGREAL;



          VAR D1Mach    : LONGREAL;

              b         : LONGREAL;

              ExpDigits : INTEGER;

BEGIN

     b:=VAL(LONGREAL,LowLong.radix);

     ExpDigits:=VAL(CARDINAL,ln(VAL(LONGREAL,LowLong.expoMax+1)) / ln(2.0));



     (* TIO.WrStr("ExpDigits = "); TIO.WrCard(ExpDigits,3); TIO.WrLn; *)



     IF    (i = 1) THEN (* the smallest positive magnitude. *)

       D1Mach:=power(b,VAL(LONGREAL,LowLong.expoMin)); 

     ELSIF (i = 2) THEN

       D1Mach:=MAX(LONGREAL); (* the largest magnitude. *)

     ELSIF (i = 3) THEN (* the smallest relative spacing. *)

       D1Mach:=power(b,VAL(LONGREAL,  -(LowLong.places - ExpDigits - 1))); 

     ELSIF (i = 4) THEN (* the largest relative spacing. *)

       D1Mach:=power(b,VAL(LONGREAL,(1-(LowLong.places - ExpDigits - 1)))); 

     ELSIF (i = 5) THEN

       D1Mach:=MachEps;

     ELSIF (i = 6) THEN

       D1Mach:=LowLong.succ(1.0) - 1.0;

     ELSE

       ErrOut("Falsches Argument von D1Mach.");

       HALT;

     END;

     RETURN D1Mach;

END D1Mach;



END F77func.