rlink1.F File Reference

#include "implicit_f.inc"
#include "com01_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	rlink1 (ms, in, a, ar, nsn, ic, icr, nod, weight, frl6, iflag)

Function/Subroutine Documentation

rlink1()

subroutine rlink1	(		ms,
			in,
			a,
			ar,
		integer	nsn,
		integer	ic,
		integer	icr,
		integer, dimension(*)	nod,
		integer, dimension(*)	weight,
		double precision, dimension(15,6)	frl6,
		integer	iflag )

Definition at line 31 of file rlink1.F.

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-----------------------------------------------
#include      "com01_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NSN, IC, ICR, IFLAG
      INTEGER NOD(*),WEIGHT(*)
C     REAL
      my_real
     .   ms(*), in(*), a(3,*), ar(3,*)
      DOUBLE PRECISION FRL6(15,6)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I, N, K
C     REAL
      my_real
     .   mass, iner, ax, ay, az,
     .   f1(nsn), f2(nsn), f3(nsn), f4(nsn)
C-----------------------------------------------
      IF(iflag == 1)THEN
 
C Init Parith/ON
       DO k = 1, 6
         frl6(1,k) = zero
         frl6(2,k) = zero
         frl6(3,k) = zero
         frl6(4,k) = zero
         frl6(5,k) = zero
         frl6(6,k) = zero
         frl6(7,k) = zero
         frl6(8,k) = zero
         frl6(9,k)  = zero
         frl6(10,k) = zero
         frl6(11,k) = zero
         frl6(12,k) = zero
         frl6(13,k) = zero
         frl6(14,k) = zero
         frl6(15,k) = zero
       END DO
 
       IF(ic==0)GOTO 150
C
       DO i=1,nsn
        n = nod(i)
        IF(weight(n)==1) THEN
          f1(i)=ms(n)
          f2(i)=ms(n)*a(1,n)
          f3(i)=ms(n)*a(2,n)
          f4(i)=ms(n)*a(3,n)
        ELSE
          f1(i)=zero
          f2(i)=zero
          f3(i)=zero
          f4(i)=zero
        ENDIF
       ENDDO
C
C Traitement Parith/ON avant echange
C
       CALL sum_6_float(1  ,nsn  ,f1, frl6(1,1), 15)
       CALL sum_6_float(1  ,nsn  ,f2, frl6(2,1), 15)
       CALL sum_6_float(1  ,nsn  ,f3, frl6(3,1), 15)
       CALL sum_6_float(1  ,nsn  ,f4, frl6(4,1), 15)
 
  150  IF(icr==0.OR.iroddl==0)RETURN
C
       DO i=1,nsn
        n = nod(i)
        IF(weight(n)==1) THEN
          f1(i)=in(n)
          f2(i)=in(n)*ar(1,n)
          f3(i)=in(n)*ar(2,n)
          f4(i)=in(n)*ar(3,n)
        ELSE
          f1(i)=zero
          f2(i)=zero
          f3(i)=zero
          f4(i)=zero
        ENDIF
       ENDDO
C
C Traitement Parith/ON avant echange
C
       CALL sum_6_float(1  ,nsn  ,f1, frl6(5,1), 15)
       CALL sum_6_float(1  ,nsn  ,f2, frl6(6,1), 15)
       CALL sum_6_float(1  ,nsn  ,f3, frl6(7,1), 15)
       CALL sum_6_float(1  ,nsn  ,f4, frl6(8,1), 15)
 
C
      ELSEIF(iflag == 2)THEN
C
       IF(ic==0)GOTO 250
C
       mass = frl6(1,1)+frl6(1,2)+frl6(1,3)+
     +        frl6(1,4)+frl6(1,5)+frl6(1,6)
       ax = frl6(2,1)+frl6(2,2)+frl6(2,3)+
     +      frl6(2,4)+frl6(2,5)+frl6(2,6)
       ay = frl6(3,1)+frl6(3,2)+frl6(3,3)+
     +      frl6(3,4)+frl6(3,5)+frl6(3,6)
       az = frl6(4,1)+frl6(4,2)+frl6(4,3)+
     +      frl6(4,4)+frl6(4,5)+frl6(4,6)
C
       IF(mass==zero)GOTO 250
       ax=ax/mass
       ay=ay/mass
       az=az/mass
C
       IF(ic==1.OR.ic==3.OR.ic==5.OR.ic==7)THEN
        DO 110 i=1,nsn
         n = nod(i)
         a(3,n) =az
  110   CONTINUE
       ENDIF
       IF(ic==2.OR.ic==3.OR.ic==6.OR.ic==7)THEN
        DO 120 i=1,nsn
         n = nod(i)
         a(2,n) =ay
  120   CONTINUE
       ENDIF
       IF(ic==4.OR.ic==5.OR.ic==6.OR.ic==7)THEN
        DO 130 i=1,nsn
         n = nod(i)
         a(1,n) =ax
  130   CONTINUE
       ENDIF
C
  250  IF(icr==0.OR.iroddl==0)RETURN
C
       iner = frl6(5,1)+frl6(5,2)+frl6(5,3)+
     +        frl6(5,4)+frl6(5,5)+frl6(5,6)
       ax = frl6(6,1)+frl6(6,2)+frl6(6,3)+
     +      frl6(6,4)+frl6(6,5)+frl6(6,6)
       ay = frl6(7,1)+frl6(7,2)+frl6(7,3)+
     +      frl6(7,4)+frl6(7,5)+frl6(7,6)
       az = frl6(8,1)+frl6(8,2)+frl6(8,3)+
     +      frl6(8,4)+frl6(8,5)+frl6(8,6)
C
       IF(iner==zero)RETURN
C
       ax=ax/iner
       ay=ay/iner
       az=az/iner
C
       IF(icr==1.OR.icr==3.OR.icr==5.OR.icr==7)THEN
        DO 210 i=1,nsn
         n = nod(i)
         ar(3,n) =az
  210   CONTINUE
       ENDIF
       IF(icr==2.OR.icr==3.OR.icr==6.OR.icr==7)THEN
        DO 220 i=1,nsn
         n = nod(i)
         ar(2,n) =ay
  220   CONTINUE
       ENDIF
       IF(icr==4.OR.icr==5.OR.icr==6.OR.icr==7)THEN
        DO 230 i=1,nsn
         n = nod(i)
         ar(1,n) =ax
  230   CONTINUE
       ENDIF
      END IF
C
      RETURN