lib/Geompack/general.f

   1 C
   2 C     The following code was excerpted from: initcb.f
   3 C
   4       SUBROUTINE INITCB(TOLIN)
   5       IMPLICIT LOGICAL (A-Z)
   6       DOUBLE PRECISION TOLIN
   7 C
   8 C     Written and copyright by:
   9 C        Barry Joe, Dept. of Computing Science, Univ. of Alberta
  10 C        Edmonton, Alberta, Canada  T6G 2H1
  11 C        Phone: (403) 492-5757      Email: barry@cs.ualberta.ca
  12 C
  13 C     Purpose: Initialize global variables in common blocks
  14 C        GERROR, GCONST, and GPRINT. The latter is used for
  15 C        printing debugging information.
  16 C
  17 C     Input parameters:
  18 C        TOLIN - relative tolerance used to determine TOL
  19 C
  20 C     Output parameters in common blocks:
  21 C        IERR - error code, initialized to 0
  22 C        PI - ACOS(-1.0D0)
  23 C        TOL - relative tolerance MAX(TOLIN,100.0D0*EPS) where
  24 C              EPS is approximation to machine epsilon
  25 C        IPRT - standard output unit 6
  26 C        MSGLVL - message level, initialized to 0
  27 C
  28       INTEGER IERR,IPRT,MSGLVL
  29       DOUBLE PRECISION PI,TOL
  30       COMMON /GERROR/ IERR
  31       COMMON /GCONST/ PI,TOL
  32       COMMON /GPRINT/ IPRT,MSGLVL
  33       SAVE /GERROR/,/GCONST/,/GPRINT/
  34 C
  35       DOUBLE PRECISION EPS,EPSP1
  36 C
  37       IERR = 0
  38       PI = ACOS(-1.0D0)
  39       EPS = 1.0D0
  40    10 CONTINUE
  41          EPS = EPS/2.0D0
  42          EPSP1 = 1.0D0 + EPS
  43       IF (EPSP1 .GT. 1.0D0) GO TO 10
  44       TOL = MAX(TOLIN,100.0D0*EPS)
  45       IPRT = 6
  46       MSGLVL = 0
  47       END
  48 C
  49 C     The following code was excerpted from: rotiar.f
  50 C
  51       SUBROUTINE ROTIAR(N,ARR,SHIFT)
  52       IMPLICIT LOGICAL (A-Z)
  53       INTEGER N,SHIFT
  54       INTEGER ARR(0:N-1)
  55 C
  56 C     Written and copyright by:
  57 C        Barry Joe, Dept. of Computing Science, Univ. of Alberta
  58 C        Edmonton, Alberta, Canada  T6G 2H1
  59 C        Phone: (403) 492-5757      Email: barry@cs.ualberta.ca
  60 C
  61 C     Purpose: Rotate elements of integer array.
  62 C
  63 C     Input parameters:
  64 C        N - number of elements of array
  65 C        ARR(0:N-1) - integer array
  66 C        SHIFT - amount of (left) shift or rotation; ARR(SHIFT) on input
  67 C              becomes ARR(0) on output
  68 C
  69 C     Updated parameters:
  70 C        ARR(0:N-1) - rotated integer array
  71 C
  72       INTEGER A,B,I,J,K,L,M,R,SH,T
  73 C
  74       SH = MOD(SHIFT,N)
  75       IF (SH .LT. 0) SH = SH + N
  76       IF (SH .EQ. 0) RETURN
  77       A = N
  78       B = SH
  79    20 CONTINUE
  80          R = MOD(A,B)
  81          A = B
  82          B = R
  83       IF (R .GT. 0) GO TO 20
  84       M = N/A - 1
  85       DO 40 I = 0,A-1
  86          T = ARR(I)
  87          K = I
  88          DO 30 J = 1,M
  89             L = K + SH
  90             IF (L .GE. N) L = L - N
  91             ARR(K) = ARR(L)
  92             K = L
  93    30    CONTINUE
  94          ARR(K) = T
  95    40 CONTINUE
  96       END