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

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