Sources Esope | Cast3M

k1k2
C K1K2      SOURCE    MB234859  26/06/04    21:15:28     12564          
      SUBROUTINE K1K2(MELE,MINTE,MINTE1,NBN2,NBN1,NBNN,SWORK,
     >                  KK,KERRE)
C----------------------------------------------------------------------
C
C PASSAGE D'UN SPG DE CHAMELEM VERS UN AUTRE SPG DE DEGRE INFERIEUR ---
C
C----------------------------------------------------------------------
      IMPLICIT REAL*8(A-H,O-Z)
-INC CCREEL
-INC PPARAM
-INC CCOPTIO
-INC SMINTE
      SEGMENT SWORK
        REAL*8 VAL1(NBN1),VAL2(NBN2),VALN(NBN2)
        REAL*8 SHP1(6,NBN1),SHP2(6,NBN2),XE(3,NBNN)
      ENDSEGMENT
      SEGMENT/AMOI/(BM(NBN2,NBN1)*D,AM(NBN2,NBN2)*D,VAL3(NBN1)*D)
C
      JDIM=KERRE
      IF(JDIM.EQ.0) THEN
         KERRE=29
         RETURN
      ENDIF
C
      KERRE=0
 
      SEGINI AMOI
 
C   Verification cas 2D ou 3D ou 1D plan
      IFR = IFOUR+4
      GO TO (81,81,81,81,81,82,83,83,83,83,83,83,83,83,83),IFR
 89   KERRE=29
      GO TO 99
 81   IDK=3
      GO TO 86
 82   IDK=4
      GO TO 86
 83   IDK=2
 86   CONTINUE
CCC --- CHAMP SOMMET --> CHAMP CENTRE
      ISDJC=0
      IF(NBN2.EQ.1) THEN
         VV=0.D0
         DO 30 IC=1,MINTE1.SHPTOT(/3)
            DO 33 ID=1,IDK
               DO 331 IE=1,NBN1
                  SHP1(ID,IE)=MINTE1.SHPTOT(ID,IE,IC)
 331           CONTINUE
 33         CONTINUE
            CALL GTEMRD(XE,SHP1,JDIM,NBN1,DJAC)
            IF (DJAC.LT.0) ISDJC=ISDJC+1
            DJAC=ABS(DJAC)*MINTE1.POIGAU(IC)
            IF(IFR.EQ.4.OR.IFR.EQ.5) THEN
               CALL DISTRR(XE,SHP1,NBNN,RR)
               IF(IFR.EQ.4.OR.(IFR.EQ.5.AND.
     +              NIFOUR.EQ.0)) THEN
                  DJAC=DJAC*RR*2*XPI
               ELSE
                  DJAC=DJAC*RR*XPI
               ENDIF
            ENDIF
               DO 31 IB=1,NBN1
                  VAL3(IB)=VAL3(IB)+SHP1(1,IB)*DJAC
                  VV=VV+SHP1(1,IB)*DJAC
 31            CONTINUE
30       CONTINUE
C
        IF (ISDJC.NE.0 .AND. ISDJC.NE.MINTE1.SHPTOT(/3)) THEN
          KERRE=195
          GOTO 99
        ENDIF
C
               WW=0.D0
               DO 32 IB=1,NBN1
                  WW=WW+VAL3(IB)*VAL1(IB)
 32            CONTINUE
               VAL2(1)=WW/VV
 
CCC --- CHAMP SOMMET --> CHAMP CENTREP1 ou MSOMMET
      ELSE
         VV=0.D0
         ISDJC=0
         DO 40 IC=1,MINTE1.SHPTOT(/3)
          DO 43 ID=1,IDK
            DO 431 IE=1,NBN1
              SHP1(ID,IE)=MINTE1.SHPTOT(ID,IE,IC)
 431        CONTINUE
            DO 432 IE=1,NBN2
              SHP2(ID,IE)=SHPTOT(ID,IE,IC)
 432        CONTINUE
 43       CONTINUE
          IF (KK.EQ.1) THEN
            CALL GTEMRD(XE,SHP1,JDIM,NBNN,DJAC)
            IF (DJAC.LT.0) ISDJC=ISDJC+1
            DJAC=ABS(DJAC)*MINTE1.POIGAU(IC)
          ELSEIF (KK.EQ.2) THEN
            CALL GTEMRD(XE,SHP2,JDIM,NBNN,DJAC)
            IF (DJAC.LT.0) ISDJC=ISDJC+1
            DJAC=ABS(DJAC)*POIGAU(IC)
          ENDIF
          IF(IFR.EQ.4.OR.IFR.EQ.5) THEN
            IF (KK.EQ.1) THEN
              CALL DISTRR(XE,SHP1,NBNN,RR)
            ELSEIF (KK.EQ.2) THEN
              CALL DISTRR(XE,SHP2,NBNN,RR)
            ENDIF
            IF(IFR.EQ.4.OR.(IFR.EQ.5.AND.
     +         NIFOUR.EQ.0)) THEN
              DJAC=DJAC*RR*2*XPI
            ELSE
              DJAC=DJAC*RR*XPI
            ENDIF
          ENDIF
C
C     CALCUL DE LA MATRICE ET DU SECOND MEMBRE
C
          DO 20 IA=1,NBN2
            DO 21 IB=1,NBN1
              BM(IA,IB)=BM(IA,IB)+SHP1(1,IB)*SHP2(1,IA)*DJAC
 21         CONTINUE
            DO 22 IB=1,NBN2
              AM(IA,IB)=AM(IA,IB)+SHP2(1,IB)*SHP2(1,IA)*DJAC
 22         CONTINUE
 20       CONTINUE
40     CONTINUE
C
        IF (ISDJC.NE.0 .AND. ISDJC.NE.MINTE1.SHPTOT(/3)) THEN
          KERRE=195
          GOTO 99
        ENDIF
C         WRITE(6,77883)((BM(I,J),J=1,NBN1),I=1,NBN2)
C77883    FORMAT(' MATRICE BM '/(6(1X,1PE12.5)/))
C         WRITE(6,77884)((AM(I,J),J=1,NBN2),I=1,NBN2)
C77884    FORMAT(' MATRICE AM '/(6(1X,1PE12.5)/))
         SOM=0.D0
         DO 63 IA=1,NBN2
            SOM=SOM+AM(IA,IA)
 63      CONTINUE
         IF(SOM.EQ.0.D0) THEN
            KERRE=358
            GO TO 99
         ENDIF
         PREC=1.D-40
         CALL INVALM(AM,NBN2,NBN2,KERRE,PREC)
C         WRITE(6,77885)((AM(I,J),J=1,NBN2),I=1,NBN2)
C77885    FORMAT(' MATRICE A-1'/(6(1X,1PE12.5)/))
C
C     T{AUTRES} = (inve(A))*B*T{SOMMET}
C
            DO 36 IA=1,NBN2
               SS=0.
               DO 37 IB=1,NBN1
               SS=SS+BM(IA,IB)*VAL1(IB)
 37            CONTINUE
               VALN(IA)=SS
 36         CONTINUE
 
            DO 48 IA=1,NBN2
               SS=0.
               DO 49 IB=1,NBN2
               SS=SS+AM(IA,IB)*VALN(IB)
 49            CONTINUE
               VAL2(IA)=SS
 48         CONTINUE
      ENDIF
 
 
 99      CONTINUE
         SEGSUP AMOI
CC      ENDIF
C
      RETURN
      END