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