Télécharger la plaquette Cast3M


fr en

Télécharger crevec.eso

Retour à la liste

Numérotation des lignes : 

crevec

  1. C CREVEC    SOURCE    PV        22/04/20    10:59:13     11344          
  2. C  CE SOUS-PROGRAMME CREE LES CHAMPS DE COORDONNEES ASSOCIES AUX
  3. C  VECTEURS. IL ACTUALISE LES ELEMENTS SUR CES CHAMPS
  4. C
  5.       SUBROUTINE CREVEC(MELE,ICPR,KABCOR,LABCO2,MVECTE,IDEF)
  6.       IMPLICIT INTEGER(I-N)
  7.  
  8.       implicit real*8(a-h,o-z)
  9. -INC PPARAM
  10. -INC CCOPTIO
  11. -INC SMELEME
  12. -INC SMCOORD
  13. -INC SMCHPOI
  14. -INC SMVECTE
  15.       SEGMENT KABCOR(1)
  16.       SEGMENT KABCO2(2,NVEC)
  17.       SEGMENT LABCO2(3,1)
  18.       SEGMENT SXCOR
  19.        REAL    XCOR(IDIM,NCO)
  20.       ENDSEGMENT
  21.       SEGMENT SXCO2
  22.        REAL   XCO2(IDIM,NCO)
  23.       ENDSEGMENT
  24.       SEGMENT ICO2(NCO)
  25.       SEGMENT ICPR(nbpts)
  26.       SEGACT MCOORD
  27.       SEGACT MVECTE
  28.         NVEC=AMPF(/1)
  29.       SEGINI KABCO2
  30.       IF (IDEF.NE.0) LABCO2(1,IDEF)=KABCO2
  31.       IF (IDEF.EQ.0) THEN
  32.         SEGINI ICPR,KABCOR,LABCO2
  33.         LABCO2(1,1)=KABCO2
  34.         LABCO2(3,1)=MVECTE
  35.        NCO=0
  36. C  ON COMMENCE PAR REMPLIR ICPR AVEC LE MELEME
  37.        DO 10 I=1,nbpts
  38.        ICPR(I)=0
  39.   10   CONTINUE
  40.        MELEME=MELE
  41.        SEGACT MELEME
  42.        NBSOUS=LISOUS(/1)
  43.        IPT1=MELEME
  44.        DO 20 ISOUS=1,MAX(1,NBSOUS)
  45.        IF (NBSOUS.NE.0) THEN
  46.         IPT1=LISOUS(ISOUS)
  47.         SEGACT IPT1
  48.        ENDIF
  49.        DO 23 I=1,IPT1.NUM(/1)
  50.        DO 22 J=1,IPT1.NUM(/2)
  51.        IP=IPT1.NUM(I,J)
  52.        IF (ICPR(IP).NE.0) GOTO 22
  53.        NCO=NCO+1
  54.        ICPR(IP)=NCO
  55.   22   CONTINUE
  56.   23   CONTINUE
  57.   20   CONTINUE
  58. C  PUIS ON COMPLETE AVEC LE SUPPORT DE CHAQUE CHAMPOIN
  59.        DO 200 IVEC=1,NVEC
  60.        MCHPOI=ICHPO(IVEC)
  61.        SEGACT MCHPOI
  62.        NSOUPO=IPCHP(/1)
  63.        DO 24 ISOUP=1,NSOUPO
  64.        MSOUPO=IPCHP(ISOUP)
  65.        SEGACT MSOUPO
  66.        IPT1=IGEOC
  67.        SEGACT IPT1
  68.        DO 27 J=1,IPT1.NUM(/2)
  69.        IP=IPT1.NUM(1,J)
  70.        IF (ICPR(IP).NE.0) GOTO 27
  71.        NCO=NCO+1
  72.        ICPR(IP)=NCO
  73.   27   CONTINUE
  74.   24   CONTINUE
  75.   200  CONTINUE
  76.        SEGINI SXCOR
  77.        KABCOR(1)=SXCOR
  78. C  MAINTENANT INITIALISER XCOR
  79.        DO 220 I=1,nbpts
  80.        IP=ICPR(I)
  81.        IF (IP.EQ.0) GOTO 220
  82.        DO 221 J=1,IDIM
  83.        XCOR(J,IP)=XCOOR((I-1)*(IDIM+1)+J)
  84.  221   CONTINUE
  85.  220   CONTINUE
  86.       ELSE
  87.        SXCOR=KABCOR(IDEF)
  88.        NCO=XCOR(/2)
  89.       ENDIF
  90. C  MAINTENANT CREER LES COORDONNEES DEFORMES XCO2
  91.       DO 300 IVEC=1,NVEC
  92. **    write(6,*) ' crevec nco ',nco
  93.       SEGINI ICO2,SXCO2
  94.       KABCO2(2,IVEC)=ICO2
  95.       KABCO2(1,IVEC)=SXCO2
  96.        DO 230 I=1,nbpts
  97.        IP=ICPR(I)
  98.        IF (IP.EQ.0) GOTO 230
  99.        DO 231 J=1,IDIM
  100.        XCO2(J,IP)=XCOR(J,IP)
  101.  231   CONTINUE
  102.  230   CONTINUE
  103.        IF (NOCOVE(IVEC,1).EQ.'SI11'.OR.NOCOVE(IVEC,1).EQ.
  104.      &    'SI22'.OR.NOCOVE(IVEC,1).EQ.'SI33') THEN
  105. *
  106. *      Cas des contraintes principales
  107. *
  108.       AMP=AMPF(IVEC)
  109.       MCHPOI=ICHPO(IVEC)
  110.       SEGACT MCHPOI
  111.       MSOUPO=IPCHP(1)
  112.       SEGACT MSOUPO
  113.       MPOVAL=IPOVAL
  114.       SEGACT MPOVAL
  115.       IPT2=IGEOC
  116.       SEGACT IPT2
  117. *
  118.       DO 600 IEL=1,IPT2.NUM(/2)
  119.          IP=ICPR(IPT2.NUM(1,IEL))
  120.          IF (IP.EQ.0) GOTO 600
  121.          IF (VPOCHA(IEL,IDIM+1).EQ.0.D0) THEN
  122.             ICO2(IP)=1
  123.          ELSE
  124.             ICO2(IP)=-1
  125.          ENDIF
  126.          DO 500 INUM=1,IDIM
  127.             XCO2(INUM,IP)=XCO2(INUM,IP)+AMP*VPOCHA(IEL,INUM)
  128.  500     CONTINUE
  129. **     write(6,*) '0 xco2 dans crevec',ip,xco2,(xco2(j,ip),j=1,idim )
  130.  600  CONTINUE
  131. *
  132.        ELSE IF (NOCOVE(IVEC,1).EQ.'FIS1'.OR.NOCOVE(IVEC,1).EQ.
  133.      &    'FIS2'.OR.NOCOVE(IVEC,1).EQ.'FIS3') THEN
  134. *
  135. *      Cas des fissures
  136. *
  137.       AMP=AMPF(IVEC)
  138.       MCHPOI=ICHPO(IVEC)
  139.       SEGACT MCHPOI
  140.       MSOUPO=IPCHP(1)
  141.       SEGACT MSOUPO
  142.       MPOVAL=IPOVAL
  143.       SEGACT MPOVAL
  144.       IPT2=IGEOC
  145.       SEGACT IPT2
  146. *
  147.       DO 700 IEL=1,IPT2.NUM(/2)
  148.          IP=ICPR(IPT2.NUM(1,IEL))
  149.          IF (IP.EQ.0) GOTO 700
  150.          SCOS = 0.D0
  151.          DO 710 II = 1,IDIM
  152.             SCOS = SCOS + ABS(VPOCHA(IEL,II))
  153.  710     CONTINUE
  154.          IF (SCOS.LT.1.E-7) THEN
  155.             ICO2(IP)=-1
  156.          ELSE
  157.             ICO2(IP)=1
  158.          ENDIF
  159.          DO 720 INUM=1,IDIM
  160.             XCO2(INUM,IP)=XCO2(INUM,IP)+AMP*VPOCHA(IEL,INUM)
  161.  720     CONTINUE
  162. **     write(6,*) '1 xco2 dans crevec',ip,xco2,(xco2(j,ip),j=1,idim )
  163.  700  CONTINUE
  164. *
  165. c debut ajout BP
  166.       ELSEIF (NOCOVE(IVEC,1).EQ.'VEC1'.OR.NOCOVE(IVEC,1).EQ.
  167.      &    'VEC2'.OR.NOCOVE(IVEC,1).EQ.'VEC3') THEN
  168. *
  169. *      Cas des vecteurs construit depouis chamelem + listmots (vecte4)
  170. *
  171.       AMP=AMPF(IVEC)
  172.       MCHPOI=ICHPO(IVEC)
  173.       SEGACT MCHPOI
  174.       MSOUPO=IPCHP(1)
  175.       SEGACT MSOUPO
  176.       MPOVAL=IPOVAL
  177.       SEGACT MPOVAL
  178.       IPT2=IGEOC
  179.       SEGACT IPT2
  180. *
  181.       DO 666 IEL=1,IPT2.NUM(/2)
  182.          IP=ICPR(IPT2.NUM(1,IEL))
  183.          IF (IP.EQ.0) GOTO 666
  184.          ICO2(IP)=1
  185.          DO 555 INUM=1,IDIM
  186.             XCO2(INUM,IP)=XCO2(INUM,IP)+AMP*VPOCHA(IEL,INUM)
  187.  555     CONTINUE
  188. **     write(6,*) '2 xco2 dans crevec',ip,xco2,(xco2(j,ip),j=1,idim )
  189.  666  CONTINUE
  190. c fin ajout BP
  191.  
  192.        ELSE
  193. *
  194. *      Cas des vecteurs
  195. *
  196. **    write(6,*) ' crevec mvecte idef ',mvecte,idef,ampf(ivec)
  197.       AMP=AMPF(IVEC)
  198.       MCHPOI=ICHPO(IVEC)
  199.       SEGACT MCHPOI
  200.       NSOUPO=IPCHP(/1)
  201.       DO 60 ISOUP=1,NSOUPO
  202.       MSOUPO=IPCHP(ISOUP)
  203.       SEGACT MSOUPO
  204.       MPOVAL=IPOVAL
  205.       SEGACT MPOVAL
  206.       IPT2=IGEOC
  207.       SEGACT IPT2
  208. *
  209.       NC=NOCOMP(/2)
  210.       DO 70 INUM=1,IDIM
  211.       DO 80 IC=1,NC
  212.       IF (NOCOMP(IC).EQ.NOCOVE(IVEC,INUM)) GOTO 81
  213.   80  CONTINUE
  214.       GOTO 70
  215.   81  CONTINUE
  216.       DO 90 IEL=1,IPT2.NUM(/2)
  217.       IP=ICPR(IPT2.NUM(1,IEL))
  218.       IF (IP.EQ.0) GOTO 90
  219.       XCO2(INUM,IP)=XCO2(INUM,IP)+AMP*VPOCHA(IEL,IC)
  220.       ICO2(IP)=1
  221.   90  CONTINUE
  222.   70  CONTINUE
  223. **     write(6,*) '3 xco2 dans crevec',ip,xco2,(xco2(j,ip),j=1,idim )
  224.   60  CONTINUE
  225. *+*
  226.        ENDIF
  227.  300  CONTINUE
  228.       SEGDES MVECTE
  229.       END
  230.  
  231.  
  232.  
  233.  
  234.  
  235.  
  236.  
  237.  
  238.  
  239.  

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