C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE SPRING (MP, ML, MS, MXNPER, MXND, MAXNBC, MAXSBC, L,
     &   IPOINT, COOR, IPBOUN, LINKP, ILINE, LTYPE, NINT, FACTOR, LCON,
     &   ILBOUN, ISBOUN, LINKL, NLPB, JFLINE, JLLIST, LINKPB, NPPF,
     &   IFPB, LISTPB, LINKLB, NLPF, IFLB, LISTLB, LINKSB, NSPF, IFSB,
     &   LISTSB, LSTNBC, X, Y, NID, XN, YN, NUID, LXK, NNN, KKK, LLL,
     &   KNBC, KSBC, ERR, ADDLNK, COUNT, NOROOM, AMESUR, XNOLD, YNOLD,
     &   NXKOLD, MMPOLD, LINKEG, LISTEG, BMESUR, MLINK, NPROLD, NPNOLD,
     &   NPEOLD, NNXK, REMESH, REXMIN, REXMAX, REYMIN, REYMAX, IDIVIS,
     &   SIZMIN, EMAX, EMIN, GRAPH)
C***********************************************************************

C  SUBROUTINE SPRING = GENERATES SPRING ELEMENTS FROM A BARSET

C***********************************************************************

      DIMENSION IPOINT(MP), COOR(2, MP), IPBOUN(MP), LINKP(2, MP)
      DIMENSION ILINE(ML), LTYPE(ML), NINT(ML), FACTOR(ML), LCON(3, ML)
      DIMENSION ILBOUN(ML), ISBOUN(ML), LINKL(2, ML)
      DIMENSION NLPB(MS), JFLINE(MS), JLLIST(MS*3)
      DIMENSION NPPF(MP), IFPB(MP), LISTPB(2, MP)
      DIMENSION NLPF(ML), IFLB(ML), LISTLB(2, ML)
      DIMENSION NSPF(ML), IFSB(ML), LISTSB(2, ML)
      DIMENSION LINKPB(2, MP)
      DIMENSION LINKLB(2, ML), LINKSB(2, ML)
      DIMENSION X(MXNPER), Y(MXNPER), NID(MXNPER)
      DIMENSION XN(MXND), YN(MXND), NUID(MXND), LXK(4,MXND)

      DIMENSION AMESUR(NPEOLD), XNOLD(NPNOLD), YNOLD(NPNOLD)
      DIMENSION NXKOLD(NNXK, NPEOLD), MMPOLD(3, NPROLD)
      DIMENSION LINKEG(2, MLINK), LISTEG(4 * NPEOLD), BMESUR(NPNOLD)

      LOGICAL NOROOM, ERR, REAL, TEST, ADDLNK, COUNT, GRAPH

      REAL = .TRUE.
      TEST = .FALSE.
      KKK = 0
      NNN = 0
      KNBC = 0
      KSBC = 0
      LLL = 1

C  CHECK THAT THE BARSET HAS ONLY TWO SIDES AND THAT THE SIDES HAVE
C  EQUAL INTERVALS

      IF (NLPB (L) .NE. 2) THEN
         ERR = .TRUE.
         CALL MESSAGE(' SPRINGS CAN ONLY BE GENERATED FOR 2 LINE BAR '//
     &      'SETS')
         GOTO 130
      ELSE
         J1 = JFLINE(L)
         J2 = JFLINE(L) + 1
         CALL LTSORT (ML, LINKL, JLLIST(J1), KK1, ADDLNK)
         CALL LTSORT (ML, LINKL, JLLIST(J2), KK2, ADDLNK)
         IF (NINT (KK1) .NE. NINT (KK2)) THEN
            CALL MESSAGE('SPRING BAR SETS MUST CONTAIN EQUAL '//
     &         'INTERVALS ON OPPOSING SIDES')
            ERR = .TRUE.
            GOTO 130
         ENDIF
      ENDIF

C  NOW GENERATE THE NODES FOR THE FIRST LINE

      CALL LTSORT (MP, LINKP, LCON(1, KK1), IP1, ADDLNK)
      CALL LTSORT (MP, LINKP, LCON(2, KK1), IP2, ADDLNK)
      IF (LCON(3, KK1) .GT. 0) THEN
         CALL LTSORT (MP, LINKP, LCON(3, KK1), IP3, ADDLNK)
      ELSE IF (LCON(3, KK1) .LT. 0) THEN
         CALL LTSORT (MP, LINKP, ABS(LCON(3, KK1)), IP3,
     &      ADDLNK)
         IP3 = -IP3
      ELSE
         IP3 = 0
      END IF

      CALL PLINE (MP, ML, MXNPER, MAXNBC, MAXSBC, IPOINT,
     &   COOR, LINKP, ILINE(KK1), LTYPE(KK1), NINT(KK1),
     &   FACTOR(KK1), IP1, IP2, IP3, X, Y, NID,
     &   IPBOUN(IP1), IPBOUN(IP2), ILBOUN(KK1), ISBOUN(KK1),
     &   LINKPB, NPPF, IFPB, LISTPB, LINKLB, NLPF, IFLB,
     &   LISTLB, LINKSB, NSPF, IFSB, LISTSB, LSTNBC, KNBC,
     &   KSBC, ERR, TEST, REAL, COUNT, NOROOM, AMESUR, XNOLD, YNOLD,
     &   NXKOLD, MMPOLD, LINKEG, LISTEG, BMESUR, MLINK, NPROLD, NPNOLD,
     &   NPEOLD, NNXK, REMESH, REXMIN, REXMAX, REYMIN, REYMAX, IDIVIS,
     &   SIZMIN, EMAX, EMIN, GRAPH, DXMAX)
      IF (ERR) THEN
         CALL MESSAGE('PROBLEMS GENERATING NODES FOR FIRST SPRING LINE')
         GOTO 130
      ENDIF

C  ADD THESE NODES TO THE CURRENT LIST

      NNN0 = NNN + 1
      NNN = NNN + ABS(NINT(KK1)) + 1
      KOUNT = 0
      DO 100 I = NNN0, NNN
         KOUNT = KOUNT+1
         XN(I) = X(KOUNT)
         YN(I) = Y(KOUNT)
         NUID(I) = NID(KOUNT)
  100 CONTINUE

C  MARK THESE POINTS AND THE LINE AS BEING USED

      NINT(KK1) = -ABS(NINT(KK1))
      IPOINT(IP1) = -ABS(IPOINT(IP1))
      IPOINT(IP2) = -ABS(IPOINT(IP2))

C  NOW GENERATE THE NODES FOR THE SECOND LINE

      CALL LTSORT (MP, LINKP, LCON(1, KK2), IP1, ADDLNK)
      CALL LTSORT (MP, LINKP, LCON(2, KK2), IP2, ADDLNK)
      IF (LCON(3, KK2) .GT. 0) THEN
         CALL LTSORT (MP, LINKP, LCON(3, KK2), IP3, ADDLNK)
      ELSE IF (LCON(3, KK2) .LT. 0) THEN
         CALL LTSORT (MP, LINKP, ABS(LCON(3, KK2)), IP3,
     &      ADDLNK)
         IP3 = -IP3
      ELSE
         IP3 = 0
      END IF

      CALL PLINE (MP, ML, MXNPER, MAXNBC, MAXSBC, IPOINT,
     &   COOR, LINKP, ILINE(KK2), LTYPE(KK2), NINT(KK2),
     &   FACTOR(KK2), IP1, IP2, IP3, X, Y, NID,
     &   IPBOUN(IP1), IPBOUN(IP2), ILBOUN(KK2), ISBOUN(KK2),
     &   LINKPB, NPPF, IFPB, LISTPB, LINKLB, NLPF, IFLB,
     &   LISTLB, LINKSB, NSPF, IFSB, LISTSB, LSTNBC, KNBC,
     &   KSBC, ERR, TEST, REAL, COUNT, NOROOM, AMESUR, XNOLD, YNOLD,
     &   NXKOLD, MMPOLD, LINKEG, LISTEG, BMESUR, MLINK, NPROLD, NPNOLD,
     &   NPEOLD, NNXK, REMESH, REXMIN, REXMAX, REYMIN, REYMAX, IDIVIS,
     &   SIZMIN, EMAX, EMIN, GRAPH, DXMAX)
      IF (ERR) THEN
         CALL MESSAGE('PROBLEMS GENERATING NODES FOR FIRST SPRING LINE')
         GOTO 130
      ENDIF

C  ADD THESE NODES TO THE CURRENT LIST

      NNN1 = NNN + 1
      NNN = NNN + ABS(NINT(KK2)) + 1
      KOUNT = 0
      DO 110 I = NNN1, NNN
         KOUNT = KOUNT + 1
         XN(I) = X(KOUNT)
         YN(I) = Y(KOUNT)
         NUID(I) = NID(KOUNT)
  110 CONTINUE

C  MARK THESE POINTS AND THE LINE AS BEING USED

      NINT(KK2) = -ABS(NINT(KK2))
      IPOINT(IP1) = -ABS(IPOINT(IP1))
      IPOINT(IP2) = -ABS(IPOINT(IP2))

C  NOW GENERATE THE ELEMENTS BY SEEING WHICH END OF THE LINE MATCHES
C  UP THE CLOSEST.

      DIST1 = SQRT ( (XN(NNN0) - XN(NNN1))**2 +
     &   (YN(NNN0) - YN(NNN1))**2 )
      DIST2= SQRT ( (XN(NNN0) - XN(NNN))**2 +
     &   (YN(NNN0) - YN(NNN))**2 )
      NK = ABS(NINT(KK1)) + 1
      DO 120 I = 1, NK
         KKK = KKK + 1
         LXK(1,KKK) = I
         IF (DIST1 .LE. DIST2) THEN
            LXK(2,KKK) = I + NK
         ELSE
            LXK(2,KKK) = NNN - I + 1
         ENDIF
         LXK(3,KKK) = 0
         LXK(4,KKK) = 0
  120 CONTINUE

  130 CONTINUE

      END
