Télécharger la plaquette Cast3M


fr en

Télécharger ch1ch2.eso

Retour à la liste

Numérotation des lignes : 

ch1ch2

  1. C CH1CH2    SOURCE    MB234859  26/06/04    21:15:07     12564          
  2.       SUBROUTINE CH1CH2(MELE,MINTE,MINTE1,NBPTEL,NBPGA1,NBNN,SWORK,
  3.      >                  AMOI,KERRE)
  4. C----------------------------------------------------------------------
  5. C
  6. C    PASSAGE DES VALEURS D'UN JEU DE POINTS DE GAUSS A UN AUTRE
  7. C
  8. C----------------------------------------------------------------------
  9. C    MINTE    POINTEUR SUR LES POINTS ET POIDS DE CH2
  10. C    MINTE1   POINTEUR SUR LES POINTS ET POIDS DE CH1
  11. C    NBPTEL   NBRE DE POINTS DE GAUSS DE CH2
  12. C    NBPGA1   NBRE DE POINTS DE GAUSS DE CH1
  13. C    NBNN     NBRE DE NOEUDS DE L'ELEMENT
  14. C    SWORK    SEGMENT DE TRAVAIL
  15. C    KERRE    EN ENTREE : DIMENSION
  16. C             EN SORTIE : CODE D'ERREUR  ( 0 SI OK )
  17. C----------------------------------------------------------------------
  18.       IMPLICIT INTEGER(I-N)
  19.       IMPLICIT REAL*8(A-H,O-Z)
  20. -INC CCREEL
  21. -INC PPARAM
  22. -INC CCOPTIO
  23. -INC SMINTE
  24.       SEGMENT/SWORK/(VAL1(NBPGA1)*D,VAL2(NBPTEL)*D,VALN(NBNN)*D,
  25.      .     SHP(6,NBNN)*D,XE(3,NBNN)*D)
  26.       SEGMENT/AMOI/(AM(NBNN,NBNN)*D,BM(NBNN)*D,CM(NBNN)*D)
  27. C= Quelques constantes (2.Pi et 4.Pi)
  28.       PARAMETER (X2Pi=6.283185307179586476925286766559D0)
  29.       PARAMETER (X4Pi=12.566370614359172953850573533118D0)
  30. C
  31.       XCOEF=1.d0
  32.       IF( mele.ge.85.and.mele.le.90) xcoef = 0.5d0
  33.       if( mele.ge.108.and.mele.le.110) xcoef=0.5D0
  34.       if(mele.eq.12.or.mele.eq.13) xcoef=0.5D0
  35.       if(mele.ge.18.and.mele.le.21) xcoef=0.5D0
  36.       if(mele.ge.185.and.mele.le.190) xcoef=0.5D0
  37. C
  38.       JDIM=KERRE
  39.       IF(JDIM.EQ.0) THEN
  40.         KERRE=29
  41.         RETURN
  42.       ENDIF
  43. C
  44.       KERRE=0
  45.       IF (NBPGA1.EQ.1) THEN
  46.         DO 10 IA=1,NBNN
  47.           VALN(IA)=VAL1(1)
  48.  10     CONTINUE
  49.         DO 11 IB=1,NBPTEL
  50.           VAL2(IB)=VAL1(1)
  51.  11     CONTINUE
  52. C
  53.       ELSE IF (NBPGA1.GT.1) THEN
  54.         IF(IIMPI.EQ.529) WRITE(6,77883)  NBPGA1,NBNN
  55. 77883   FORMAT('0  NB DE POINTS DE GAUSS ',I4,2X,
  56.      .        'NB DE NOEUDS ' ,I4/)
  57.  
  58. C       Precondionnement pour pas faire SEGINI par Pts Support
  59.         IF(AMOI.EQ.0)THEN
  60.           SEGINI,AMOI
  61.         ELSEIF(BM(/1) .NE. NBNN)THEN
  62.           SEGADJ,AMOI
  63.         ENDIF
  64.         CALL ZERO(AM(1,1),NBNN,NBNN)
  65.         CALL ZERO(BM(1  ),NBNN,1   )
  66.         VV=0.D0
  67.         ISDJC=0
  68.         DO 30 IC=1,NBPGA1
  69. C
  70. C         CALCUL DU JACOBIEN
  71. C
  72.           DO IE=1,NBNN
  73.             SHP(1,IE)=MINTE1.SHPTOT(1,IE,IC)
  74.             SHP(2,IE)=MINTE1.SHPTOT(2,IE,IC)
  75.             SHP(3,IE)=MINTE1.SHPTOT(3,IE,IC)
  76.             SHP(4,IE)=MINTE1.SHPTOT(4,IE,IC)
  77.           ENDDO
  78. C
  79.           CALL GTEMRD(XE,SHP,JDIM,NBNN,DJAC)
  80.           IF (DJAC.LT.0) ISDJC=ISDJC+1
  81.           DJAC=ABS(DJAC)*MINTE1.POIGAU(IC)
  82. C
  83.           IF (IFOUR.EQ.0.OR.IFOUR.EQ.1) THEN
  84.             CALL DISTRR(XE,SHP,NBNN,RR)
  85.             IF( IFOUR.EQ.0 .OR.
  86.      &         (IFOUR.EQ.1.AND.NIFOUR.EQ.0)) THEN
  87.               DJAC=DJAC*RR*2*XPI
  88.             ELSE
  89.               DJAC=DJAC*RR*XPI
  90.             ENDIF
  91.           ELSE IF (IFOUR.GE.12.AND.IFOUR.LE.14) THEN
  92.             CALL DISTRR(XE,SHP,NBNN,RR)
  93.             DJAC=X2Pi*DJAC*RR
  94.           ELSE IF (IFOUR.EQ.15) THEN
  95.             CALL DISTRR(XE,SHP,NBNN,RR)
  96.             DJAC=X4Pi*DJAC*RR
  97.           ENDIF
  98. C
  99.           VV=VV+DJAC
  100. C
  101. C         CALCUL DE LA MATRICE ET DU SECOND MEMBRE
  102. C
  103.           XVAL1=VAL1(IC)
  104.           DO 20 IB=1,NBNN
  105.             XSHP1=SHP(1,IB)
  106.             DO 21 IA=1,NBNN
  107.               AM(IA,IB)=AM(IA,IB)+SHP(1,IA)*XSHP1*DJAC
  108.  21         CONTINUE
  109.             BM(IB)=BM(IB)+SHP(1,IB)*XVAL1*DJAC
  110.  20       CONTINUE
  111.  30     CONTINUE
  112. C
  113.         IF (ISDJC.NE.0 .AND. ISDJC.NE.NBPGA1) THEN
  114.           KERRE=195
  115.           GOTO 99
  116.         ENDIF
  117. C
  118.         if (nbptel.gt.nbpga1) then
  119. *  dans le cas du tri6 et du coq6, on impose les noeuds milieux par penalisation
  120.          if (mele.eq.6.or.mele.eq.56) then
  121.            call chnsng(am,nbnn,2,1,3)
  122.            call chnsng(am,nbnn,4,3,5)
  123.            call chnsng(am,nbnn,6,5,1)
  124.          endif
  125. *  dans le cas du q8ri et du coq8, on impose les noeuds milieux par penalisation
  126.          if (mele.eq.184.or.mele.eq.41) then
  127.            call chnsng(am,nbnn,2,1,3)
  128.            call chnsng(am,nbnn,4,3,5)
  129.            call chnsng(am,nbnn,6,5,7)
  130.            call chnsng(am,nbnn,8,7,1)
  131.          endif
  132. *  dans le cas du tet10, on impose les noeuds milieux par penalisation
  133.          if (mele.eq.24) then
  134.            call chnsng(am,nbnn,2,1,3)
  135.            call chnsng(am,nbnn,4,3,5)
  136.            call chnsng(am,nbnn,6,5,1)
  137.            call chnsng(am,nbnn,7,1,10)
  138.            call chnsng(am,nbnn,8,3,10)
  139.            call chnsng(am,nbnn,9,5,10)
  140.          endif
  141. *  dans le cas du cu20, on impose les noeuds milieux par penalisation
  142.          if (mele.eq.15) then
  143.            call chnsng(am,nbnn,2,1,3)
  144.            call chnsng(am,nbnn,4,3,5)
  145.            call chnsng(am,nbnn,6,5,7)
  146.            call chnsng(am,nbnn,8,7,1)
  147.            call chnsng(am,nbnn,9,1,13)
  148.            call chnsng(am,nbnn,10,3,15)
  149.            call chnsng(am,nbnn,11,5,17)
  150.            call chnsng(am,nbnn,12,7,19)
  151.            call chnsng(am,nbnn,14,13,15)
  152.            call chnsng(am,nbnn,16,15,17)
  153.            call chnsng(am,nbnn,18,17,19)
  154.            call chnsng(am,nbnn,20,19,13)
  155.          endif
  156. *  dans le cas du pr15, on impose certains noeuds milieux par penalisation
  157.          if (mele.eq.17) then
  158.            call chnsng(am,nbnn,2,1,3)
  159.            call chnsng(am,nbnn,4,3,5)
  160.            call chnsng(am,nbnn,6,5,1)
  161.            call chnsng(am,nbnn,11,10,12)
  162.            call chnsng(am,nbnn,13,12,14)
  163.            call chnsng(am,nbnn,15,14,10)
  164.          endif
  165.         endif
  166. C
  167.         DO 62 IA=1,NBNN
  168.           CM(IA)=AM(IA,IA)
  169.  62     CONTINUE
  170.  
  171.         SOM=0.D0
  172.         DO 63 IA=1,NBNN
  173.           SOM=SOM+CM(IA)
  174.  63     CONTINUE
  175.         IF (SOM.EQ.0.D0) THEN
  176.           KERRE=358
  177.           GOTO 61
  178.         ENDIF
  179.  
  180.         IF(IIMPI.EQ.529) WRITE(6,77884)((AM(I,J),J=1,NBNN),I=1,NBNN)
  181. 77884   FORMAT(' MATRICE AM '/(6(1X,1PE12.5)/))
  182.         PREC=1.D-10
  183.         CALL INVALM(AM,NBNN,NBNN,KERRE,PREC)
  184.  61     IF (KERRE.NE.0) THEN
  185. C
  186. C     A EST SINGULIERE - ON MOYENNE  |
  187. C
  188.           KERRE=0
  189.           IF(IIMPI.GE.529) WRITE(6,77854)
  190. 77854     FORMAT(' A EST SINGULIERE - ON MOYENNE ' /)
  191.           SOM=0.D0
  192.           DO 64 IC=1,NBPGA1
  193.             SOM=SOM+VAL1(IC)
  194.  64       CONTINUE
  195.           SOM=SOM/NBPGA1
  196.           DO 65 IA=1,NBNN
  197.             VALN(IA)=SOM
  198.  65       CONTINUE
  199. C
  200.         ELSE
  201.           CALL ZERO(VALN(1),NBNN,1)
  202.           DO 40 IB=1,NBNN
  203.             XBM1=BM(IB)
  204.             DO 41 IA=1,NBNN
  205.               VALN(IA)=VALN(IA)+AM(IA,IB)*XBM1
  206.  41         CONTINUE
  207.  40       CONTINUE
  208.         ENDIF
  209. C
  210. C       CALCUL DES VALEURS AUX POINTS DE GAUSS
  211. C
  212. *  AM  18/4/16
  213.         MELGEO=NUMGEO(MELE)
  214.         IDECA=0
  215.         IF(MELGEO.EQ.29) IDECA=2
  216.         IF(MELGEO.EQ.30) IDECA=3
  217.         IF(MELGEO.EQ.31) IDECA=4
  218.         NBNOU=NBNN-IDECA
  219. *
  220.         DO 50 IB=1,NBPTEL
  221.           VA=0.D0
  222.           DO 51 IC=1,NBNOU
  223.             VA=VA+SHPTOT(1,IC,IB)*VALN(IC)
  224.  51       CONTINUE
  225.           VAL2(IB)=VA*xcoef
  226.  50     CONTINUE
  227. C
  228.  99     CONTINUE
  229.       ENDIF
  230.       END
  231.  
  232.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales