Sources Esope | Cast3M

icalp
C ICALP     SOURCE    BP208322  15/09/21    21:15:04     8627
      INTEGER FUNCTION ICALP (X,Y)
*
* X (E) : BORNE INF D'AXE
* Y (E) : BORNE SUP D'AXE
*
*   RETOURNE N TEL QUE X SOUS FORMAT  X' *10 E N
*   AVEC  1 &lt;ou= X' &lt; 10
*   EXCEPTION 0
*
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Y)
*
      if (x.gt.-1d50.and.x.lt.1d50) then
      if (y.gt.-1d50.and.y.lt.1d50) then
*
      B=ABS(X)
      N=0
      IF (B.EQ.0.d0) GOTO 3
1     IF (B.LT.1.D0) THEN
         B=B*10
         N=N-1
         GOTO 1
      ENDIF
2     IF (B.GE.10.D0) THEN
         B=B/10
         N=N+1
         GOTO 2
      ENDIF
*
3     N2=N
      B=ABS(Y)
      N=0
      IF (B.EQ.0.D0) GOTO 6
4     IF (B.LT.1.D0) THEN
         B=B*10
         N=N-1
         GOTO 4
      ENDIF
5     IF (B.GE.10.D0) THEN
         B=B/10
         N=N+1
         GOTO 5
      ENDIF
6     N1=N
*
*     ON PREND L'EXPOSANT LE + GRAND, SAUF SI UNE BORNE EST 0
      IF (N1.GT.N2) THEN
         IF (Y.EQ.0.D0) THEN
            IP=N2
         ELSE
            IP=N1
         ENDIF
      ELSE
         IF (X.EQ.0.D0) THEN
            IP=N1
         ELSE
            IP=N2
         ENDIF
      ENDIF
 
* UN NOMBRE A 2 CHIFFRES ON LE LAISSE TEL QUEL
      IF (ABS(IP).EQ.1) IP=0
* BP : on LAISSE AUSSI LES NOMBRES A 3 et 4 CHIFFRES :
      IF (IP.GT.0.AND.IP.LE.3) IP=0
 
      ICALP=IP
      return
*
      endif
      endif
*
      icalp=0
      END