1 : C COMCRE SOURCE FANDEUR 12/07/18 21:15:09 7435 2 : SUBROUTINE COMCRE(iqmod,ipcon,irang,mocomp,lscont,IPMINT, 3 : & lesupp,iwrk53,jluc,iretou) 4 : *- 5 : * cree les deche necessaires associees aux noms de composantes 6 : * et au rang argument (en sortie a priori) 7 : * garde les adresses dans une pile 8 : *- 9 : *---------------------------------------------------------------- 10 : IMPLICIT INTEGER(I-N) 11 : IMPLICIT REAL*8(A-H,O-Z) 12 : * 13 : -INC CCOPTIO 14 : -INC SMMODEL 15 : -INC SMCHAML 16 : c*-INC SMINTE 17 : -INC DECHE 18 : * 19 : imodel = iqmod 20 : wrk53 = iwrk53 21 : 22 : lilcon = ipcon 23 : iilcon=lilcon(/1) 24 : ijlcon=iilcon 25 : 26 : pilnec = lscont 27 : ** segact pilnec*mod 28 : mobl = pilobl(/1) 29 : mfac = pilfac(/1) 30 : 31 : *------------------------------------------------- 32 : *** jecree=0 veut dire de ne pas recreer le champ s'il existe en entrée 33 : *** mais le récupérer. 34 : jecree = 1 35 : jtestj = 0 36 : if (jluc.eq.2.or.jluc.eq.15) then 37 : jecree=0 38 : else if (jluc.eq.14) then 39 : jecree=0 40 : else if(jluc.eq.13) then 41 : if (formod(1).eq.'MECANIQUE') then 42 : jecree=0 43 : else if (formod(1).eq.'POREUX') then 44 : if (inplas.ge.0) jecree=0 45 : else if (formod(1).eq.'LIAISON') then 46 : jecree=0 47 : else if (formod(1).eq.'MELANGE') then 48 : if (cmate.eq.'PARALLEL') jecree=0 49 : endif 50 : * specifique pour endommagement sic_sic 51 : if (inplas.eq. 88) jtestj=15 52 : * specifique pour viscoplastique parfait 53 : if (inplas.eq. 43) jtestj=6 54 : * specifique pour plastique isotrope tuyau 55 : if (inplas.eq. 5) jtestj=3 56 : * specifique pour orthotrope viscoplastique mistral 57 : if (inplas.eq. 94) jtestj=15 58 : endif 59 : 60 : nomid = mocomp 61 : ** segact nomid*nomod 62 : 63 : nobl = lesobl(/2) 64 : nfac = lesfac(/2) 64 : call cotype(iqmod,jluc,motype,iwrk53,nobl,nfac) 65 : notype = motype 66 : 67 : nbtype = 0 68 : if (notype.NE.0) then 69 : nbtype = type(/2) 70 : ENDIF 71 : if (nbtype.ne.0) GOTO 200 72 : * 73 : do jm =1,mobl 74 : dec1=pilobl(jm,2) 75 : if(dec1.eq.0) then 76 : dec1=pilobl(jm,1) 77 : endif 78 : if (FORMOD(1).EQ.'MELANGE'.and.cmate.eq.'PARALLEL' 79 : &.and.pilobl(jm,3).gt.0 ) dec1 = pilobl(jm,3) 80 : if (dec1.gt.0) then 81 : segini,deche=dec1 82 : indec = irang 83 : ijlcon=ijlcon+1 84 : if(ijlcon.gt.iilcon) then 85 : iilcon=iilcon+mobl+mfac 86 : segadj lilcon 87 : endif 88 : lilcon(ijlcon) = deche 89 : if (jecree.eq.1) then 90 : if (typdec(1:8).eq.'REAL*8') then 91 : N1PTEL=NBPTEL 92 : N1EL=NEL 93 : N2PTEL=0 94 : N2EL=0 95 : else 96 : N2PTEL=NBPTEL 97 : N2EL=NEL 98 : N1PTEL=0 99 : N1EL=0 100 : endif 101 : segini melval 102 : ieldec = melval 103 : ** segdes melval 104 : else 105 : * write(6,*) 'deche imite',nomdec,ieldec,n1ptel,n1el,condec,jecree 106 : endif 107 : ** segdes deche 108 : pilobl(jm,irang)= deche 109 : endif 110 : enddo 111 : 112 : do jm =1,mfac 113 : dec1=pilfac(jm,2) 114 : if (dec1.gt.0) then 115 : segini,deche=dec1 116 : indec = irang 117 : ijlcon=ijlcon+1 118 : if(ijlcon.gt.iilcon) then 119 : iilcon=iilcon+mfac 120 : segadj lilcon 121 : endif 122 : lilcon(ijlcon) = deche 123 : if(jecree.eq.1) then 124 : if (typdec(1:8).eq.'REAL*8') then 125 : N1PTEL=NBPTEL 126 : N1EL=NEL 127 : N2PTEL=0 128 : N2EL=0 129 : else 130 : N2PTEL=NBPTEL 131 : N2EL=NEL 132 : N1PTEL=0 133 : N1EL=0 134 : endif 135 : segini melval 136 : ieldec = melval 137 : ** segdes melval 138 : endif 139 : ** segdes deche 140 : pilfac(jm,irang)= deche 141 : endif 142 : enddo 143 : 144 : GOTO 50 145 : 146 : 200 CONTINUE 147 : deche = lilcon(1) 148 : ** segact deche*nomod 149 : * n3 a revoir 150 : n3 = infdec(/1) 151 : ** segdes deche 152 : do 30 jm = 1, mobl 153 : dec1=pilobl(jm,irang-1) 154 : if(dec1.eq.0) dec1=pilobl(jm,1) 155 : segini deche 156 : ijlcon=ijlcon+1 157 : if( ijlcon.gt.iilcon) then 158 : iilcon=iilcon + mobl + mfac 159 : segadj lilcon 160 : endif 161 : lilcon(ijlcon) = deche 162 : pilobl(jm,irang)=deche 163 : nomdec = lesobl(jm) 164 : imadec = imamod 165 : ICMN=MIN(jm,NBTYPE) 166 : typdec = type(icmn) 167 : 168 : condec = conmod 169 : ifodec = IFOUR 170 : indec = irang 171 : infdec(1) = 0 172 : infdec(2) = 0 173 : infdec(3) = NIFOUR 174 : infdec(4) = IPMINT 175 : infdec(5) = 0 176 : infdec(6) = lesupp 177 : * 178 : if(jecree.eq.0) then 179 : if(jm.le.jtestj.and.jluc.eq.13)go to 356 180 : if(dec1.ne.0) then 181 : segact dec1 182 : ieldec = dec1.ieldec 183 : * write(6,*) 'dec rep', nomdec, ieldec, deche,condec 184 : ******** segdes dec1 185 : go to 345 186 : endif 187 : endif 188 : 356 continue 189 : if (type(icmn)(1:8).eq.'REAL*8') then 190 : N1PTEL=NBPTEL 191 : N1EL=NEL 192 : N2PTEL=0 193 : N2EL=0 194 : else 195 : N2PTEL=NBPTEL 196 : N2EL=NEL 197 : N1PTEL=0 198 : N1EL=0 199 : endif 200 : segini melval 201 : * write(6,*) 'cree ',nomdec,melval,n1ptel,n1el,condec 202 : ieldec = melval 203 : ** segdes melval 204 : 345 continue 205 : ** segdes deche 206 : 30 continue 207 : 208 : do 31 jm =1,mfac 209 : dec1=pilfac(jm,irang-1) 210 : if(dec1.eq.0) dec1=pilfac(jm,1) 211 : if (jluc.eq.20) then 212 : if (formod(1).eq.'LIAISON') goto 340 213 : * kich : composantes facultatives MODAL / STATIQUE 214 : else if (jluc.eq.11) then 215 : if (imatee.eq.9 .or. imatee.eq.10) goto 340 216 : endif 217 : if(dec1.eq.0) go to 31 218 : 340 segini deche 219 : ijlcon=ijlcon+1 220 : if(ijlcon.gt.iilcon) then 221 : iilcon = iilcon+mfac 222 : segadj lilcon 223 : endif 224 : lilcon(ijlcon) = deche 225 : pilfac(jm,irang)=deche 226 : nomdec = lesfac(jm) 227 : imadec = imamod 228 : ICMN=MIN(jm+nobl,NBTYPE) 229 : typdec = type(icmn) 230 : condec = conmod 231 : ifodec = IFOUR 232 : indec = irang 233 : infdec(1) = 0 234 : infdec(2) = 0 235 : infdec(3) = NIFOUR 236 : infdec(4) = IPMINT 237 : infdec(5) = 0 238 : infdec(6) = lesupp 239 : if(jecree.eq.0.and.dec1.gt.0) then 240 : segact dec1 241 : ieldec=dec1.ieldec 242 : ** segdes dec1 243 : * write(6,*) 'dec fac rep', nomdec, ieldec, deche,condec 244 : go to 346 245 : endif 246 : if (type(icmn)(1:8).eq.'REAL*8') then 247 : N1PTEL=NBPTEL 248 : N1EL=NEL 249 : N2PTEL=0 250 : N2EL=0 251 : else 252 : N2PTEL=NBPTEL 253 : N2EL=NEL 254 : N1PTEL=0 255 : N1EL=0 256 : endif 257 : * 258 : segini melval 259 : * write(6,*) 'cree fac',cmatee,nomdec,melvaln1ptel,n1el,condec 260 : ieldec = melval 261 : *********** segdes melval 262 : 346 continue 263 : ******** segdes deche 264 : 31 continue 265 : 266 : 50 CONTINUE 267 : ** segdes nomid,pilnec 268 : segsup notype 269 : * 270 : if (iilcon.ne.ijlcon) then 271 : iilcon=ijlcon 272 : segadj lilcon 273 : endif 274 : 275 : RETURN 276 : END 277 : 278 :
© Cast3M 2003 - All rights reserved.
Disclaimer