Sources Esope | Cast3M

kremp2
C KREMP2    SOURCE    CHAT      05/01/13    01:06:22     5004
      SUBROUTINE KREMP2 (K1,K2,O1,A2,C,U2,SHC2D,SKBUF2,SKRESO)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C     DIM 2   INTERIEUR D'UN CONTOUR
C     ------------------------------
C
C-----------------------------------------------------------------------
      SEGMENT SKRESO
      INTEGER KFC,NRES,KES,KIMP
      ENDSEGMENT
C     KFC : NOMBRE DE FACES H.C
C     NRES: RESOLUTION
C     KES : DIM ESPACE
C     KIMP: IMPRESSION
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
      SEGMENT SHC2D
      INTEGER IR(NR),KA(NFC),IM(NFC,NFC)
      INTEGER KRO(NFC,NES),KSI(NFC,NES)
      REAL*8  V(NES,NR),G(NR)
      ENDSEGMENT
 
C     DESCRIPTION DU H.C DE PROJECTION
C     --------------------------------
C     V : DIRECTION UNITAIRE DES CELLULES
C     G : FACTEUR DE FORME ASSOCIE
C     IR: CORRESPONDANCE
C     KRO , KSI : POUR LE CHANGEMENT DE REPERE
C     IM  : REFERENCE
C     NR  : RESOLUTION
C     NFC : NOMBRE DE FACES
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
      SEGMENT SKBUF2
      INTEGER  NUMF(NFC,NOC,NR),NTYP(NFC,NR)
      REAL*8   ZB(NFC,NR),PSC(NFC,NR)
      ENDSEGMENT
C
C     BUFFER ASSOCIE AU H.C
C     ---------------------
C     NUMF : INDICE DE LE DERNIERE FACE RENCONTREE
C     NTYP :  TYPES ASSOCIES
C     ZB  : PROFONDEUR
C     PSC  :  PRODUIT SCALAIRE (NORMALE.DIRECTION CELLULE)
C-----------------------------------------------------------------------
      DIMENSION O1(2),X1(2),X2(2),U2(1)
      DIMENSION X(2),XR(2),XR1(2),XR2(2)
      DIMENSION A2(2,2)
C
      DO 100 K=1,2
      X1(K)=A2(K,1)
      X2(K)=A2(K,2)
 100  CONTINUE
C
      IF (KIMP.GE.4) WRITE(6,*) ' X1 ',X1(1),X1(2),' X2 ',X2(1),X2(2)
C
C     PROJECTION DES 2 SOMMETS
C
      CALL KAPCU2(KES,X1,O1,NRES,XR1,NF1,LS1)
      IF (KIMP.GE.4) WRITE(6,*) ' NF1 LS1 XR1 ',NF1,LS1,XR1(1),XR1(2)
 
      CALL KAPCU2(KES,X2,O1,NRES,XR2,NF2,LS2)
      IF (KIMP.GE.4) WRITE(6,*) ' NF2 LS2 XR2 ',NF2,LS2,XR2(1),XR2(2)
 
      CALL KREMS2(K2,NF1,LS1,C,U2,SHC2D,SKBUF2,SKRESO)
      CALL KREMS2(K2,NF2,LS2,C,U2,SHC2D,SKBUF2,SKRESO)
C
      IF(NF1.EQ.NF2) THEN
C
C     UNE SEULE FACE
C     --------------
      LMIN = MIN0(LS1,LS2)
      LMAX = MAX0(LS1,LS2)
       IF((LMAX-LMIN).GE.2 ) THEN
       CALL K2EMPI(K2,NF1,LMIN+1,LMAX-1,C,U2,SHC2D,SKBUF2,SKRESO)
       ENDIF
 
      ELSE
C
C      DEUX FACES DIFFERENTES   1) PARALLELES  2) NON PARALLELES
C      ---------------------------------------------------------
        IF (KA(NF1).EQ.KA(NF2)) THEN
        IF (KIMP.GE.4) WRITE(6,*) ' KREMP2 CAS PARALLELE'
        KAC = KA(NF1)
         DO 1 K=1,KES
         X(K) = (X1(K)+X2(K))/2
  1      CONTINUE
         IF(KIMP.GE.4) WRITE(6,*) ' X ',X(1),X(2)
 
         II = 0
 10      CONTINUE
         II = II + 1
 
         IF (II.GE.12) THEN
           WRITE(6,*) ' non convergence de la dichotomie'
           RETURN
         ELSEIF (II.GE.10) THEN
 
          IF((NF1.EQ.1).OR.(NF1.EQ.2)) X(1)=O1(1)
          IF((NF1.EQ.3).OR.(NF1.EQ.4)) X(2)=O1(2)
 
         ENDIF
 
         CALL KAPC21(KES,X,O1,NRES,XR,NF,LS,KAC)
 
         IF (NF.EQ.NF1) THEN
 
            DO 2 K = 1,KES
            X(K) = (X(K)+X2(K))/2
 2          CONTINUE
              GOTO 10
         ELSE
          IF(NF.EQ.NF2) THEN
              DO 3 K = 1,KES
              X(K) = (X1(K)+X(K))/2
 3            CONTINUE
              GOTO 10
          ELSE
        IF (KIMP.GE.4) WRITE(6,*) '      FACE GENEREE ',NF
C
C        NF EST &lt;> NF1 ET &lt;>NF2
C
C       ---
        LEX = IM(NF1,NF)
        IF (LEX.EQ.0) THEN
         WRITE(6,*) ' PB FACES ',K1,' ',K2,' CAS 1'
        ENDIF
          KELT = LEX-LS1
          IF (KELT.GE.1 ) THEN
            CALL K2EMPI(K2,NF1,LS1+1,LEX,C,U2,SHC2D,SKBUF2,SKRESO)
          ENDIF
          IF (KELT.LE.-1) THEN
            CALL K2EMPI(K2,NF1,LEX,LS1+1,C,U2,SHC2D,SKBUF2,SKRESO)
          ENDIF
 
        LEX = IM(NF2,NF)
        IF (LEX.EQ.0) THEN
         WRITE(6,*) ' PB FACES ',K1,' ',K2,' CAS 2'
        ENDIF
          KELT = LEX-LS2
          IF (KELT.GE.1 ) THEN
            CALL K2EMPI(K2,NF2,LS2+1,LEX,C,U2,SHC2D,SKBUF2,SKRESO)
          ENDIF
          IF (KELT.LE.-1) THEN
            CALL K2EMPI(K2,NF2,LEX,LS2+1,C,U2,SHC2D,SKBUF2,SKRESO)
          ENDIF
 
          CALL K2EMPI(K2,NF,1,NRES,C,U2,SHC2D,SKBUF2,SKRESO)
C
         ENDIF
         ENDIF
C
        ELSE
          IF (KIMP.GE.4) WRITE(6,*) ' KREMP2  FACES NON PARALLES '
          LEX = IM(NF1,NF2)
        IF (LEX.EQ.0) THEN
         WRITE(6,*) ' PB FACES ',K1,' ',K2,' CAS 3'
        ENDIF
          KELT = LEX-LS1
          IF (KELT.GE.1 ) THEN
            CALL K2EMPI(K2,NF1,LS1+1,LEX,C,U2,SHC2D,SKBUF2,SKRESO)
          ENDIF
          IF (KELT.LE.-1) THEN
            CALL K2EMPI(K2,NF1,LEX,LS1-1,C,U2,SHC2D,SKBUF2,SKRESO)
          ENDIF
C
          LEX = IM(NF2,NF1)
        IF (LEX.EQ.0) THEN
         WRITE(6,*) ' PB FACES ',K1,' ',K2,' CAS 4'
        ENDIF
          KELT = LEX-LS2
          IF (KELT.GE.1 ) THEN
            CALL K2EMPI(K2,NF2,LS2+1,LEX,C,U2,SHC2D,SKBUF2,SKRESO)
          ENDIF
          IF (KELT.LE.-1) THEN
            CALL K2EMPI(K2,NF2,LEX,LS2-1,C,U2,SHC2D,SKBUF2,SKRESO)
          ENDIF
        ENDIF
      ENDIF
 
      RETURN
      END