Sources Esope | Cast3M

kcalar
C KCALAR    SOURCE    CB215821  16/04/22    21:15:03     8922           
      SUBROUTINE KCALAR(NR,XR1,IF1,KF1,XR2,IF2,KF2,NBFA,IFA,IG,NCEL,ICEL
     -              ,IC,KA,IM)
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
C--------------------------------------------------------------------
C Calcul des facteurs de forme en 3D
C Sp appele par KPROJA
C
C     DETERMINATION DE LA PROJECTION D' UNE ARETE CONNUE PAR LA
C     PROJECTION DE SES SOMMETS SUR L'H.C DE RESOLUTION NR
C
C--------------------------------------------------------------------
      DIMENSION XR1(3),KF1(2),XR2(3),KF2(2)
      DIMENSION IFA(3),IG(3,2),NCEL(3),ICEL(3,2,1),IC(2,1)
      DIMENSION KA(6),IM(6)
      DIMENSION P(3),M1(2),M2(2),KG(2)
C
      NR2 = NR/2
C     WRITE(6,*) ' IF1 IF2 ',IF1,IF2
C     WRITE(6,*) ' XR1 ',XR1(1),XR1(2),XR1(3)
C     WRITE(6,*) ' XR2 ',XR2(1),XR2(2),XR2(3)
      IF ( IF1.EQ.IF2) THEN
         NBFA = 1
         IFA(1) = IF1
         CALL KBRESE(KF1,KF2,NC,IC,KG)
         IG(1,1) = KG(1)
         IG(1,2) = KG(2)
         NCEL(1) = NC
         DO 1 I = 1,NC
         ICEL(1,1,I) = IC(1,I)
         ICEL(1,2,I) = IC(2,I)
1        CONTINUE
      ELSE
      IFA(1) = IF1
      IFA(2) = IF2
      K1 = KA(IF1)
      K2 = KA(IF2)
      IF(K1.EQ.K2) THEN
         NBFA = 0
         RETURN
      ELSE
      K3 = 6- K1- K2
      I1 = IM(IF1)
      I2 = IM(IF2)
      CALL KPVEC(XR1,XR2,P)
C     WRITE(6,*) ' P ',P(1),P(2),P(3)
      CV = ABS(P(K3))
C     WRITE(6,*) ' CV ',CV
      IF (CV.GT.1E-4) THEN
        Y = XR1(K3) - (P(K2)/P(K3))*( XR2(K2) - XR1(K2))
      ELSE
        Y = XR1(K3)
      ENDIF
C     WRITE(6,*) ' Y ',Y
      AY = ABS(Y)
 
      IF(AY.LE.1.001) THEN
       NBFA = 2
       IIY  = 1 +  INT(NR2*(1.+Y))
       IY  = MIN0(NR,IIY)
C      WRITE(6,*) ' IY ',IY
 
         IF( K2.LT.K3) THEN
                M1(1)  = I2
                M1(2)  = IY
         ELSE
                M1(1)  = IY
                M1(2)  = I2
         ENDIF
         CALL KBRESE(KF1,M1,NC,IC,KG)
         NCEL(1) = NC
         DO 2 I = 1,NC
         ICEL(1,1,I) = IC(1,I)
         ICEL(1,2,I) = IC(2,I)
 2       CONTINUE
C        IG(1,1) = KG(1)
C        IG(1,2) = KG(2)
         IG(1,1) = M1(1)
         IG(1,2) = M1(2)
 
         IF( K1.LT.K3) THEN
                M2(1)   = I1
                M2(2)   = IY
         ELSE
                M2(1)   = IY
                M2(2)   = I1
         ENDIF
         CALL KBRESE(KF2,M2,NC,IC,KG)
         NCEL(2) = NC
         DO 3 I = 1,NC
         ICEL(2,1,I) = IC(1,I)
         ICEL(2,2,I) = IC(2,I)
 3       CONTINUE
C        IG(2,1) = KG(1)
C        IG(2,2) = KG(2)
         IG(2,1) = M2(1)
         IG(2,2) = M2(2)
 
      ELSE
       NBFA = 3
       I3 = IM(IF1)
 
       IF(Y.GT.0.) THEN
            Y = 1.
            IFA(3) = 2*K3 - 1
       ELSE
            Y= -1.
            IFA(3) = 2*K3
       ENDIF
       I3 = IM(IFA(3))
 
      CV = ABS(P(K2))
      IF (CV.GT.1E-4) THEN
       X  = XR1(K2) - (P(K3)/P(K2))*( Y - XR1(K3))
      ELSE
       X = XR1(K2)
      ENDIF
 
      CV = ABS(P(K1))
      IF (CV.GT.1E-4) THEN
       Z  = XR2(K1) - (P(K3)/P(K1))*( Y - XR2(K3))
      ELSE
       Z = XR2(K1)
      ENDIF
C      WRITE(6,*) ' X Z ',X,Z
       IIX = 1 +  INT(NR2*(1+X))
       IX = MIN0(NR,IIX)
       IIZ = 1 +  INT(NR2*(1+Z))
       IZ = MIN0(NR,IIZ)
 
C     FACE IF3
         IF( K1.LT.K2) THEN
                M1(1) = I1
                M1(2) = IX
                M2(1) = IZ
                M2(2) = I2
         ELSE
                M1(1) = IX
                M1(2) = I1
                M2(1) = I2
                M2(2) = IZ
         ENDIF
         CALL KBRESE(M1,M2,NC,IC,KG)
         NCEL(3) = NC
         DO 4 I = 1,NC
         ICEL(3,1,I) = IC(1,I)
         ICEL(3,2,I) = IC(2,I)
 4       CONTINUE
         IG(3,1) = KG(1)
         IG(3,2) = KG(2)
 
C     FACE IF1
         IF( K2.LT.K3) THEN
                M1(1) = IX
                M1(2) = I3
         ELSE
                M1(1) = I3
                M1(2) = IX
         ENDIF
         CALL KBRESE(KF1,M1,NC,IC,KG)
         NCEL(1) = NC
         DO 5 I = 1,NC
         ICEL(1,1,I) = IC(1,I)
         ICEL(1,2,I) = IC(2,I)
 5       CONTINUE
C        IG(1,1) = KG(1)
C        IG(1,2) = KG(2)
         IG(1,1) = M1(1)
         IG(1,2) = M1(2)
 
C     FACE IF2
         IF( K1.LT.K3) THEN
                M2(1) = IZ
                M2(2) = I3
         ELSE
                M2(1) = I3
                M2(2) = IZ
         ENDIF
         CALL KBRESE(KF2,M2,NC,IC,KG)
         NCEL(2) = NC
         DO 6 I = 1,NC
         ICEL(2,1,I) = IC(1,I)
         ICEL(2,2,I) = IC(2,I)
 6       CONTINUE
C        IG(2,1) = KG(1)
C        IG(2,2) = KG(2)
         IG(2,1) = M2(1)
         IG(2,2) = M2(2)
 
      ENDIF
      ENDIF
      ENDIF
 
C     WRITE(6,*) ' NBFA ',NBFA
C     WRITE(6,*) ' IFA  ',(IFA(I),I=1,NBFA)
C     WRITE(6,*) ' NCEL ',(NCEL(I),I=1,NBFA)
C     DO 10 I = 1,NBFA
C     WRITE(6,*) ' IG   ',IG(I,1),IG(I,2)
C     WRITE(6,*) ' ICEL ',(ICEL(I,1,K),K=1,NCEL(I))
C     WRITE(6,*) ' JCEL ',(ICEL(I,2,K),K=1,NCEL(I))
C10   CONTINUE
C     WRITE(6,*)
      RETURN
      END