C
C ====================================================================
C ======================= B O U N D ==================================
C ====================================================================
C
      SUBROUTINE BOUND(IDOF,NNDF,NINODE,ICODE,I_OUT)
C
C ====================================================================
C I                                                                  I
C I   P R O G R A M:                                                 I
C I                                                                  I
C I   SUBROUTINE 'BOUND' CHECKS THE MOTION OF ROLLERS ON CURVED      I
C I   BOUNDARIES AND INSURES THAT THE ROLLERS STAY ON THE BOUNDARY   I
C I   BY DETERMINING THE APPROPRIATE DISPLACEMENT CORRECTIONS.       I
C I                                                                  I
C I   A R G U M E N T     L I S T:                                   I
C I                                                                  I
C I   IDOF(I)   = THE ARRAY CONTAINING THE D.O.F. NUMBERS            I
C I   NNDF      = NUMBER OF NODAL DEGREES OF FREEDOM                 I
C I   ICODE     = RETURN CODE PASSED TO THE CALLING ROUTINE          I
C I               =0; NO CHANGE IN THE D.O.F. NUMBERS                I
C I               =1; RECALCULATION OF THE 'IDOF' AARAY IS NEEDED    I
C I   I_OUT     = OUTPUT DEVICE NUMBER                               I
C I                                                                  I
C ====================================================================
C
      IMPLICIT NONE
      INTEGER MAX_NODES,MAX_SKEW_BC,MAX_INTFAC_NODES,MNNDF,MAX_NODES_DOF
      PARAMETER (MAX_NODES=3000,MAX_SKEW_BC=300,MAX_INTFAC_NODES=500,
     .           MNNDF=3,MAX_NODES_DOF=MAX_NODES*MNNDF)
      REAL*4 X,Y,Z
      INTEGER ICODE,ID1,ID2,IRELE,I_OUT,K1,NINODE,NNDF,NODE,IDOF(*)
      INTEGER INTFAC,ISPB,IRINC(MAX_INTFAC_NODES)
      REAL*8 DOT,DX,DY,R,RP,T,TOL,XFINAL,XNODE,XP,YFINAL,YNODE,YP
      REAL*8 COSTX,COSTY,COSTZ,P,RE,RINC,RIT,U,UINC,UTOTAL
      COMMON/MAIN1/U(MAX_NODES_DOF)
      COMMON/MAIN2/UTOTAL(MAX_NODES_DOF)
      COMMON/MAIN4/RE(MAX_NODES_DOF)
      COMMON/INPUT3/X(MAX_NODES),Y(MAX_NODES),Z(MAX_NODES)
      COMMON/INPUT7/RIT(MAX_NODES_DOF),RINC(MAX_NODES_DOF),
     .              UINC(MAX_NODES_DOF)
      COMMON/INPUTD/COSTX(MAX_SKEW_BC),COSTY(MAX_SKEW_BC),
     .              COSTZ(MAX_SKEW_BC)
      COMMON/INPUTE/ISPB(MAX_NODES)
      COMMON/INPUTI/INTFAC(MAX_INTFAC_NODES)
      COMMON/POINTS/P(4 , 2)
C
      TOL = 10D-18
      IRELE = 20
      ICODE = 0
C
C       NINODE = NUMBER OF INTERFACE NODES
C
      DO K1 = 1 , NINODE
        NODE = INTFAC( K1 )
        ID1 = NNDF*(NODE - 1) + 1
        ID2 = ID1 + 1
C
C       YNODE = FINAL Y-COORD OF THE NODE
C
        YNODE = Y( NODE ) + UTOTAL( ID2 )
C
C       CHECK TO SEE IF THE NODE HAS PENETRATED THE DIE
C
        IF (YNODE.GT.P(1,2).AND.YNODE.LE.P(2,2)) THEN
          XNODE = X( NODE ) + UTOTAL( ID1 )
C
C            FIND THE POINT ON THE DIE FOR A NORMAL RETURN CORRECTION
C            THE DIE IS MODELED USING THE 'HERMITE PARAMETRIC CURVE'
C            SUBROUTINE MULLER FINDS THE PARAMETER 'T'
C            SUBROUTINE HERMXY FINDS THE 'X' AND 'Y' COORDINATES OF THE
C            RETURN POINT ON THE DIE
C
          CALL MULLER(XNODE,YNODE,T,I_OUT)
          CALL HERMXY(T,XFINAL,YFINAL)
          CALL XYPRIM(T,XP,YP)
          DX = XFINAL - XNODE
          DY = YFINAL - YNODE
          R = DSQRT(DX**2 + DY**2)
          RP = DSQRT(XP**2 + YP**2)
C
C            CHANGE THE NEGATIVE 'ISPB' ADDRESSES TO POSITIVE SO THAT
C            THEY ARE RECOGNIZED IN THE SOLUTION PROCESS
C
          IF (ISPB( NODE ).LT.0) THEN
            ISPB( NODE ) = - ISPB( NODE )
          ELSE IF(ISPB( NODE ).EQ.0) THEN
            WRITE(I_OUT , 1000) NODE
            STOP '>>>>>>> PROGRAM STOPPED IN ROUTINE ''BOUND'' '
          END IF
C
C            FIND THE DIRECTION COSINES OF THE ROLLERS ON THE DIE
C
          COSTX(ISPB( NODE )) = -YP/RP
          COSTY(ISPB( NODE )) = XP/RP
          IF (IDOF( ID1 ).GT.0) THEN
            ICODE = 1
            IDOF( ID1 ) = -1
            IDOF( ID2 ) = 1
          ELSE
            IDOF( ID1 ) = -1
          END IF
C
C            IMPOSE THE APPROPRIATE DISPLACEMENT FOR THE NORMAL RETURN
C            CORRECTION DURING THE NEXT LOAD INCREMENT
C
          DOT = -YP*DX + XP*DY
          IF (DOT.GE.0) THEN
            UINC( ID1 ) = R
          ELSE
            UINC( ID1 ) = -R
          END IF
C
C       IF THE NODE EXISTS THEN RELEASE IT AND SET ICODE EQUAL TO 1 TO
C       MAKE SURE THAT THE CALLING ROUTINE RECALCULATES THE 'IDOF' ARRAY
C
        ELSE IF(YNODE.GT.P(2,2)) THEN
          UINC( ID1 ) = 0.
          IF(ISPB( NODE ).GT.0) ISPB( NODE ) = -ISPB( NODE )
          IF(IDOF( ID1 ).LE.0) THEN
            ICODE = 1
            IRINC( K1 ) = 1
            IDOF( ID1 ) = 1
            RINC( ID1 ) = -RE( ID1 )/IRELE
            RINC( ID2 ) = -RE( ID2 )/IRELE
          ELSE IF (IRINC(K1).NE.0) THEN
            IRINC( K1 ) = IRINC( K1 ) + 1
            IF (IRINC(K1).GT.IRELE) THEN
              IRINC( K1 ) = 0
              RINC( ID1 ) = 0.0
              RINC( ID2 ) = 0.0
            END IF
          END IF
        END IF
      END DO
 1000 FORMAT(1X,'>>>>>>> PROGRAM STOPPED IN ROUTINE "BOUND" DUE TO A'/
     . 9X,'ZERO ISPB FOR INTERFACE NODE ',I4)
C
      END
C
C ====================================================================
C ===================== C U R V E ====================================
C ====================================================================
C
      SUBROUTINE CURVE
      IMPLICIT NONE
      REAL*8 T,X,Y
      REAL*4 DMAG,FMAG,XE,XS,YE,YS,DT
      INTEGER ITHICK,NLINES,K1
      LOGICAL CONTOURS
      COMMON/GRAPH5/FMAG,DMAG,CONTOURS,ITHICK,NLINES
C
      CALL VTHICK(3)
      DT = 0.05
      T =  0.
      CALL HERMXY(T,X,Y)
      XS = X*FMAG
      YS = Y*FMAG
      DO K1 = 1 , 20
        T = T + DT
        CALL HERMXY(T,X,Y)
        XE = X*FMAG
        YE = Y*FMAG
        CALL CLIP(XS,YS,0.,1.,XE,YE,0.,1.)
        XS = XE
        YS = YE
      END DO
      CALL VTHICK(2)
C
      END
C
C ====================================================================
C ==================== M U L L E R ===================================
C ====================================================================
C
      SUBROUTINE MULLER(XD,YD,T,I_OUT)
      IMPLICIT NONE
      INTEGER MAX_ROOT
      PARAMETER (MAX_ROOT=5)
      REAL*8 ROOT(MAX_ROOT),A,B,C0,C1,C2,C3,C4,C5,D,D0,D1,D2,F0,F1
      REAL*8 F2,GAM,H1,H1S,H2,T0,T1,T2,TOL,XD,YD,HMAT,HMATP,T
      INTEGER K1,K2,NROOT,I_OUT,STR$COLLAPSE,LSTR1,LSTR2
      CHARACTER*40 STR1,STR2
      COMMON/HERM/HMAT(4 , 4),HMATP(4 , 2)
      COMMON/CONST/C0,C1,C2,C3,C4,C5
C
      TOL = .000000001
      D2 = C2 + 3.*(XD*HMATP(1 , 1) + YD*HMATP(1 , 2))
      D1 = C1 + 2.*(XD*HMATP(2 , 1) + YD*HMATP(2 , 2))
      D0 = C0 + XD*HMATP(3 , 1) + YD*HMATP(3 , 2)
      NROOT = 0
  10  T1 = 0.
      T2 = 1.
      T0 = 0.5
      F1 = D0
      F2 = C5 + C4 + C3 + D2 + D1 + D0
      DO K1 = 1 , NROOT
        F1 = F1/(-ROOT( K1 ))
        F2 = F2/(1. - ROOT( K1 ))
      END DO
      DO K1 = 1 , 20
        F0 = ((((C5*T0 + C4)*T0 + C3)*T0 + D2)*T0 + D1)*T0 + D0
        DO K2 = 1 , NROOT
          F0 = F0/(T0 - ROOT( K2 ))
        END DO
        H2 = T0 - T2
        H1 = T1 - T0
        H1S = H1**2
        GAM = H2/H1
        A = (GAM*F1 - F0*(1.+GAM) + F2)/(GAM*H1S*(1 + GAM))
        B = (F1 - F0 - A*H1S)/H1
        IF (B.LE.0.) THEN
          D = -DSQRT(B**2 - 4.*A*F0)
        ELSE
          D = DSQRT(B**2 - 4.*A*F0)
        END IF
        T = T0 - 2.*F0/(B+D)
        IF (DABS(T-T0).LE.TOL) GO TO 50
        IF (T.GT.T0.AND.T.NE.T2) THEN
          T1 = T0
          T0 = T
          F1 = F0
        ELSE IF(T.LT.T0.AND.T.NE.T1) THEN
          T2 = T0
          T0 = T
          F2 = F0
        ELSE
          GO TO 50
        END IF
      END DO
      WRITE(I_OUT , 1000)
 50   IF (T.GT.1..OR.T.LT.0.) THEN
        IF (NROOT.EQ.4) THEN
          WRITE(I_OUT , 1001) T
          STOP 'PROGRAM HAS STOPPED DUE TO ''T'' OUT OF RANGE'
        ELSE
          NROOT = NROOT + 1
          IF(NROOT.GT.MAX_ROOT) THEN
            WRITE(STR1,'(I39)')NROOT
            WRITE(STR2,'(I39)')MAX_ROOT
            LSTR1=STR$COLLAPSE(STR1,STR1)
            LSTR2=STR$COLLAPSE(STR2,STR2)
            WRITE(I_OUT,*)'NUMBER OF ROOTS ('//STR1(:LSTR1)//') EXCEEDS'
     .          //' ALLOWABLE (MAX_ROOT='//STR2(:LSTR2)//') IN ROUTINE '
     .          //'MULLER. PROGRAM TERMINATED'
            WRITE(*,*)'NUMBER OF ROOTS ('//STR1(:LSTR1)//') EXCEEDS'
     .          //' ALLOWABLE (MAX_ROOT='//STR2(:LSTR2)//') IN ROUTINE '
     .          //'MULLER. PROGRAM TERMINATED'
            STOP
          ENDIF
          ROOT( NROOT ) = T
          GO TO 10
        END IF
      END IF
 1000 FORMAT(/1X,'>>>>>>> FIXED POINT ITERATION FAILED')
 1001 FORMAT(/1X,'>>>>>>> PROGRAM HAS STOPPED DUE TO THE OUT OF RANGE ',
     .      'VALUE OF "T"'/9X,'T = ',F6.3)
C
      END
C
C ====================================================================
C ======================== C O E F I C ===============================
C ====================================================================
C
      SUBROUTINE COEFIC
      IMPLICIT NONE
      INTEGER K1
      REAL*8 C0,C1,C2,C3,C4,C5,HMAT,HMATP
      COMMON/HERM/HMAT(4 , 4),HMATP(4 , 2)
      COMMON/CONST/C0,C1,C2,C3,C4,C5
C
      C0 = 0.
      C1 = 0.
      C2 = 0.
      C3 = 0.
      C4 = 0.
      C5 = 0.
      DO K1 = 1 , 2
        C0 = C0 - HMATP(3 , K1)*HMATP(4 , K1)
        C1 = C1 - HMATP(3 , K1)**2 - 2.*HMATP(2 , K1)*HMATP(4 , K1)
        C2 = C2 - 3.*HMATP(1 , K1)*HMATP(4 , K1) - 3.*HMATP(2 , K1)*
     .       HMATP(3 , K1)
        C3 = C3 - 2.*HMATP(2 , K1)**2 - 4.*HMATP(1 , K1)*HMATP(3 , K1)
        C4 = C4 - 5.*HMATP(1 , K1)*HMATP(2 , K1)
        C5 = C5 - 3.*HMATP(1 , K1)**2
      END DO
C
      END
C
C ====================================================================
C ======================== H E R M I T ===============================
C ====================================================================
C
      SUBROUTINE HERMIT
      IMPLICIT NONE
      INTEGER K1,K2,K3
      REAL*8 HMAT,HMATP,P
      COMMON/POINTS/P(4 , 2)
      COMMON/HERM/HMAT(4 , 4),HMATP(4 , 2)
C
      DO K1 = 1 , 4
        DO K2 = 1 , 2
          HMATP(K1 , K2) = 0.
          DO K3 = 1 , 4
            HMATP(K1 , K2) = HMATP(K1 , K2) + HMAT(K1 , K3)*P(K3 , K2)
          END DO
        END DO
      END DO
C
      END
C
C ====================================================================
C ======================== H E R M X Y ===============================
C ====================================================================
C
      SUBROUTINE HERMXY(T,X,Y)
      IMPLICIT NONE
      REAL*8 HMAT,HMATP,T,T1(4),X,Y
      INTEGER K1
      COMMON/HERM/HMAT(4 , 4),HMATP(4 , 2)
C
      T1( 4 ) = 1.
      T1( 3 ) = T
      T1( 2 ) = T*T1( 3 )
      T1( 1 ) = T*T1( 2 )
      X = 0.
      Y = 0.
      DO K1 = 1 , 4
        X = X + T1( K1 ) * HMATP(K1 , 1)
        Y = Y + T1( K1 ) * HMATP(K1 , 2)
      END DO
C
      END
C
C ====================================================================
C ======================== X Y P R I M ===============================
C ====================================================================
C
      SUBROUTINE XYPRIM(T,XP,YP)
      IMPLICIT NONE
      REAL*8 HMAT,HMATP,T,T1(4),XP,YP
      INTEGER K1
      COMMON/HERM/HMAT(4 , 4),HMATP(4 , 2)
C
      T1( 4 ) = 0.
      T1( 3 ) = 1.
      T1( 2 ) = 2.*T
      T1( 1 ) = 3.*T**2
C
      XP=0.
      YP=0.
      DO K1=1,4
        XP=XP+T1(K1)*HMATP(K1,1)
        YP=YP+T1(K1)*HMATP(K1,2)
      END DO
C
      END
