C CREVEC SOURCE BP208322 12/05/10 21:15:00 7368 C CE SOUS-PROGRAMME CREE LES CHAMPS DE COORDONNEES ASSOCIES AUX C VECTEURS. IL ACTUALISE LES ELEMENTS SUR CES CHAMPS C SUBROUTINE CREVEC(MELE,ICPR,KABCOR,LABCO2,MVECTE,IDEF) IMPLICIT INTEGER(I-N) -INC CCOPTIO -INC SMELEME -INC SMCOORD -INC SMCHPOI -INC SMVECTE SEGMENT KABCOR(1) SEGMENT KABCO2(2,NVEC) SEGMENT LABCO2(3,1) SEGMENT XCOR(IDIM,NCO) SEGMENT XCO2(IDIM,NCO) SEGMENT ICO2(NCO) SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) SEGACT MCOORD SEGACT MVECTE NVEC=AMPF(/1) SEGINI KABCO2 IF (IDEF.NE.0) LABCO2(1,IDEF)=KABCO2 IF (IDEF.EQ.0) THEN SEGINI ICPR,KABCOR,LABCO2 LABCO2(1,1)=KABCO2 LABCO2(3,1)=MVECTE NCO=0 C ON COMMENCE PAR REMPLIR ICPR AVEC LE MELEME DO 10 I=1,XCOOR(/1)/(IDIM+1) ICPR(I)=0 10 CONTINUE MELEME=MELE SEGACT MELEME NBSOUS=LISOUS(/1) IPT1=MELEME DO 20 ISOUS=1,MAX(1,NBSOUS) IF (NBSOUS.NE.0) THEN IPT1=LISOUS(ISOUS) SEGACT IPT1 ENDIF DO 22 I=1,IPT1.NUM(/1) DO 22 J=1,IPT1.NUM(/2) IP=IPT1.NUM(I,J) IF (ICPR(IP).NE.0) GOTO 22 NCO=NCO+1 ICPR(IP)=NCO 22 CONTINUE 20 CONTINUE C PUIS ON COMPLETE AVEC LE SUPPORT DE CHAQUE CHAMPOIN DO 200 IVEC=1,NVEC MCHPOI=ICHPO(IVEC) SEGACT MCHPOI NSOUPO=IPCHP(/1) DO 24 ISOUP=1,NSOUPO MSOUPO=IPCHP(ISOUP) SEGACT MSOUPO IPT1=IGEOC SEGACT IPT1 DO 27 J=1,IPT1.NUM(/2) IP=IPT1.NUM(1,J) IF (ICPR(IP).NE.0) GOTO 27 NCO=NCO+1 ICPR(IP)=NCO 27 CONTINUE 24 CONTINUE 200 CONTINUE SEGINI XCOR KABCOR(1)=XCOR C MAINTENANT INITIALISER XCOR DO 220 I=1,XCOOR(/1)/(IDIM+1) IP=ICPR(I) IF (IP.EQ.0) GOTO 220 DO 221 J=1,IDIM XCOR(J,IP)=XCOOR((I-1)*(IDIM+1)+J) 221 CONTINUE 220 CONTINUE ELSE XCOR=KABCOR(IDEF) NCO=XCOR(/2) ENDIF C MAINTENANT CREER LES COORDONNEES DEFORMES XCO2 DO 300 IVEC=1,NVEC SEGINI ICO2,XCO2 KABCO2(2,IVEC)=ICO2 KABCO2(1,IVEC)=XCO2 DO 230 I=1,XCOOR(/1)/(IDIM+1) IP=ICPR(I) IF (IP.EQ.0) GOTO 230 DO 231 J=1,IDIM XCO2(J,IP)=XCOR(J,IP) 231 CONTINUE 230 CONTINUE IF (NOCOVE(IVEC,1).EQ.'SI11'.OR.NOCOVE(IVEC,1).EQ. & 'SI22'.OR.NOCOVE(IVEC,1).EQ.'SI33') THEN * * Cas des contraintes principales * AMP=AMPF(IVEC) MCHPOI=ICHPO(IVEC) SEGACT MCHPOI MSOUPO=IPCHP(1) SEGACT MSOUPO MPOVAL=IPOVAL SEGACT MPOVAL IPT2=IGEOC SEGACT IPT2 * DO 600 IEL=1,IPT2.NUM(/2) IP=ICPR(IPT2.NUM(1,IEL)) IF (IP.EQ.0) GOTO 600 IF (VPOCHA(IEL,IDIM+1).EQ.0.D0) THEN ICO2(IP)=1 ELSE ICO2(IP)=-1 ENDIF DO 500 INUM=1,IDIM XCO2(INUM,IP)=XCO2(INUM,IP)+AMP*VPOCHA(IEL,INUM) 500 CONTINUE 600 CONTINUE SEGDES IPT2,MPOVAL,MSOUPO,MCHPOI * ELSE IF (NOCOVE(IVEC,1).EQ.'FIS1'.OR.NOCOVE(IVEC,1).EQ. & 'FIS2'.OR.NOCOVE(IVEC,1).EQ.'FIS3') THEN * * Cas des fissures * AMP=AMPF(IVEC) MCHPOI=ICHPO(IVEC) SEGACT MCHPOI MSOUPO=IPCHP(1) SEGACT MSOUPO MPOVAL=IPOVAL SEGACT MPOVAL IPT2=IGEOC SEGACT IPT2 * DO 700 IEL=1,IPT2.NUM(/2) IP=ICPR(IPT2.NUM(1,IEL)) IF (IP.EQ.0) GOTO 700 SCOS = 0.D0 DO 710 II = 1,IDIM SCOS = SCOS + ABS(VPOCHA(IEL,II)) 710 CONTINUE IF (SCOS.LT.1.E-7) THEN ICO2(IP)=-1 ELSE ICO2(IP)=1 ENDIF DO 720 INUM=1,IDIM XCO2(INUM,IP)=XCO2(INUM,IP)+AMP*VPOCHA(IEL,INUM) 720 CONTINUE 700 CONTINUE SEGDES IPT2,MPOVAL,MSOUPO,MCHPOI * c debut ajout BP ELSEIF (NOCOVE(IVEC,1).EQ.'VEC1'.OR.NOCOVE(IVEC,1).EQ. & 'VEC2'.OR.NOCOVE(IVEC,1).EQ.'VEC3') THEN * * Cas des vecteurs construit depouis chamelem + listmots (vecte4) * AMP=AMPF(IVEC) MCHPOI=ICHPO(IVEC) SEGACT MCHPOI MSOUPO=IPCHP(1) SEGACT MSOUPO MPOVAL=IPOVAL SEGACT MPOVAL IPT2=IGEOC SEGACT IPT2 * DO 666 IEL=1,IPT2.NUM(/2) IP=ICPR(IPT2.NUM(1,IEL)) IF (IP.EQ.0) GOTO 666 ICO2(IP)=1 DO 555 INUM=1,IDIM XCO2(INUM,IP)=XCO2(INUM,IP)+AMP*VPOCHA(IEL,INUM) 555 CONTINUE 666 CONTINUE SEGDES IPT2,MPOVAL,MSOUPO,MCHPOI c fin ajout BP ELSE * * Cas des vecteurs * AMP=AMPF(IVEC) MCHPOI=ICHPO(IVEC) SEGACT MCHPOI NSOUPO=IPCHP(/1) DO 60 ISOUP=1,NSOUPO MSOUPO=IPCHP(ISOUP) SEGACT MSOUPO MPOVAL=IPOVAL SEGACT MPOVAL IPT2=IGEOC SEGACT IPT2 * NC=NOCOMP(/2) DO 70 INUM=1,IDIM DO 80 IC=1,NC IF (NOCOMP(IC).EQ.NOCOVE(IVEC,INUM)) GOTO 81 80 CONTINUE GOTO 70 81 CONTINUE DO 90 IEL=1,IPT2.NUM(/2) IP=ICPR(IPT2.NUM(1,IEL)) IF (IP.EQ.0) GOTO 90 XCO2(INUM,IP)=XCO2(INUM,IP)+AMP*VPOCHA(IEL,IC) ICO2(IP)=1 90 CONTINUE 70 CONTINUE SEGDES IPT2,MPOVAL,MSOUPO 60 CONTINUE SEGDES MCHPOI *+* ENDIF 300 CONTINUE SEGDES MVECTE RETURN END