s10edg_rlink.F File Reference

#include "implicit_f.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	s10edg_rlink (nlink, numlink, nnlink, lnlink, itagnd, icnds10, itab, ipri, numnod, ns10e)

Function/Subroutine Documentation

s10edg_rlink()

subroutine s10edg_rlink	(	integer, intent(in)	nlink,
		integer, intent(in)	numlink,
		integer, dimension(10,nlink), intent(inout)	nnlink,
		integer, dimension(numlink), intent(inout)	lnlink,
		integer, dimension(numnod), intent(inout)	itagnd,
		integer, dimension(3,ns10e), intent(in)	icnds10,
		integer, dimension(numnod), intent(in)	itab,
		integer, intent(in)	ipri,
		integer, intent(in)	numnod,
		integer, intent(in)	ns10e )

Definition at line 33 of file s10edg_rlink.F.

C=======================================================================
      USE message_mod
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER, INTENT(IN) :: NLINK,NUMLINK,IPRI,NUMNOD,NS10E
      INTEGER, DIMENSION(10,NLINK), INTENT (INOUT) :: NNLINK
      INTEGER, DIMENSION(NUMLINK),  INTENT (INOUT) :: LNLINK
      INTEGER, DIMENSION(NUMNOD),   INTENT (IN   ) :: ITAB
      INTEGER, DIMENSION(NUMNOD),   INTENT (INOUT) :: ITAGND
      INTEGER, DIMENSION(3,NS10E),  INTENT (IN   ) :: ICNDS10
C     REAL
C-----------------------------------------------
C   External function
C-----------------------------------------------
      LOGICAL INTAB
      EXTERNAL intab
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,J,K, N,ND,N1,N2,NNEW,ID,IER1,IER2
      INTEGER IAD,IU,NSL,NS,NN,NNSL
      LOGICAL IS1,IS2
      INTEGER, DIMENSION(:), ALLOCATABLE :: LL_TMP
C     REAL
       k = 0
       nnew = 0
       ier1 = 0
       ier2 = 0
       DO n=1,nlink
         nsl =  nnlink(1,n)
         iu  =  nnlink(2,n)
         DO i=1,nsl
           ns = lnlink(k+i)
           IF (itagnd(ns) /=0 ) THEN
            id = iabs(itagnd(ns))
            nd = icnds10(1,id)
            n1 = icnds10(2,id)
            n2 = icnds10(3,id)
            is1 = intab(nsl,lnlink(k+1),n1)
            is2 = intab(nsl,lnlink(k+1),n2)
            IF (is1.AND.is2) THEN
              itagnd(ns) = itagnd(ns) + ns10e
              nnew = nnew + 1
              lnlink(k+i) = -lnlink(k+i)
              ier1 =1
              IF (ipri>=5)
     .         CALL ancmsg(msgid=1213,
     .                msgtype=msginfo,
     .                anmode=aninfo_blind_1,
     .                c1='RIGID LINK ',
     .                i1=itab(nd),
     .                prmod=msg_cumu)
            ELSEIF (.NOT.(is1).AND..NOT.(is2)) THEN
C----error out ND is alone in RLINK
              CALL ancmsg(msgid=1216,
     .                msgtype=msgerror,
     .                anmode=aninfo_blind_1,
     .                i1=itab(nd),
     .                c1='RIGID LINK ',
     .                i2=iu,
     .                c2='RIGID LINK ')
            ELSE
C----removed from INN directly----------
              nnew = nnew + 1
              lnlink(k+i) = -lnlink(k+i)
              ier2 =1
              IF (ipri>=5)
     .         CALL ancmsg(msgid=1210,
     .                msgtype=msginfo,
     .                anmode=aninfo_blind_1,
     .                c1='RIGID LINK ',
     .                i1=itab(nd),
     .                prmod=msg_cumu)
            END IF
           END IF !(ITAGND(NS) /=0 ) THEN
         END DO
         IF (ier1 >0.AND.ipri>=5) THEN
            CALL ancmsg(msgid=1213,
     .                  msgtype=msginfo,
     .                  anmode=aninfo_blind_1,
     .                  c1='RIGID LINK ',
     .                  c2='RIGID LINK ',
     .                  i1=iu,
     .                  prmod=msg_print)
         END IF 
         IF (ier2 >0.AND.ipri>=5) THEN
            CALL ancmsg(msgid=1210,
     .                  msgtype=msginfo,
     .                  anmode=aninfo_blind_1,
     .                  c1='RIGID LINK ',
     .                  c2='RIGID LINK ',
     .                  i1=iu,
     .                  prmod=msg_print)
         END IF 
         k = k + nsl
       END DO
C-------nodes removed from       
       IF (nnew>0) THEN
         ALLOCATE(ll_tmp(numlink))
         ll_tmp = lnlink
         k = 0
         nn = 0
         DO n=1,nlink
           nsl =  nnlink(1,n)
           nnsl=0
           DO i=1,nsl
             ns = ll_tmp(k+i)
             IF (ns>0) THEN
               nnsl = nnsl+1
               lnlink(nn+i) = ns
             END IF
           END DO
           nnlink(1,n) = nnsl
           k = k + nsl
           nn = nn + nnsl
         END DO
         DEALLOCATE(ll_tmp)
       END IF
C       
      RETURN