C CREVEC SOURCE PV 22/04/20 10:59:13 11344 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) implicit real*8(a-h,o-z) -INC PPARAM -INC CCOPTIO -INC SMELEME -INC SMCOORD -INC SMCHPOI -INC SMVECTE SEGMENT KABCOR(1) SEGMENT KABCO2(2,NVEC) SEGMENT LABCO2(3,1) SEGMENT SXCOR REAL XCOR(IDIM,NCO) ENDSEGMENT SEGMENT SXCO2 REAL XCO2(IDIM,NCO) ENDSEGMENT SEGMENT ICO2(NCO) SEGMENT ICPR(nbpts) 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,nbpts 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 23 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 23 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 SXCOR KABCOR(1)=SXCOR C MAINTENANT INITIALISER XCOR DO 220 I=1,nbpts 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 SXCOR=KABCOR(IDEF) NCO=XCOR(/2) ENDIF C MAINTENANT CREER LES COORDONNEES DEFORMES XCO2 DO 300 IVEC=1,NVEC ** write(6,*) ' crevec nco ',nco SEGINI ICO2,SXCO2 KABCO2(2,IVEC)=ICO2 KABCO2(1,IVEC)=SXCO2 DO 230 I=1,nbpts 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 ** write(6,*) '0 xco2 dans crevec',ip,xco2,(xco2(j,ip),j=1,idim ) 600 CONTINUE * 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 ** write(6,*) '1 xco2 dans crevec',ip,xco2,(xco2(j,ip),j=1,idim ) 700 CONTINUE * 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 ** write(6,*) '2 xco2 dans crevec',ip,xco2,(xco2(j,ip),j=1,idim ) 666 CONTINUE c fin ajout BP ELSE * * Cas des vecteurs * ** write(6,*) ' crevec mvecte idef ',mvecte,idef,ampf(ivec) 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 ** write(6,*) '3 xco2 dans crevec',ip,xco2,(xco2(j,ip),j=1,idim ) 60 CONTINUE *+* ENDIF 300 CONTINUE SEGDES MVECTE END