C COMCRE SOURCE JK148537 23/08/21 21:15:07 11723 SUBROUTINE COMCRE(iqmod,ipcon,irang,mocomp,lscont,IPMINT, & lesupp,iwrk53,jluc,iretou) *- * cree les deche necessaires associees aux noms de composantes * et au rang argument (en sortie a priori) * garde les adresses dans une pile *- *---------------------------------------------------------------- IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) * -INC PPARAM -INC CCOPTIO -INC SMMODEL -INC SMCHAML -INC DECHE * imodel = iqmod wrk53 = iwrk53 lilcon = ipcon iilcon=lilcon(/1) ijlcon=iilcon pilnec = lscont mobl = pilobl(/1) mfac = pilfac(/1) *------------------------------------------------- *** jecree=0 veut dire de ne pas recreer le champ s'il existe en entrée *** mais le récupérer. jecree = 1 jtestj = 0 if (jluc.eq.2.or.jluc.eq.15) then jecree=0 else if (jluc.eq.14) then jecree=0 else if(jluc.eq.13) then if (formod(1).eq.'MECANIQUE ') then jecree=0 else if (formod(1).eq.'POREUX ') then if (inplas.ge.0) jecree=0 else if (formod(1).eq.'LIAISON ') then jecree=0 * else if (formod(1).eq.'MELANGE ') then * if (cmate.eq.'PARALLEL') jecree=0 else if (formod(1).eq.'DIFFUSION ') then jecree=0 endif * specifique pour endommagement sic_sic if (inplas.eq. 88) jtestj=15 * specifique pour viscoplastique parfait if (inplas.eq. 43) jtestj=6 * specifique pour plastique isotrope tuyau if (inplas.eq. 5) jtestj=3 * specifique pour orthotrope viscoplastique mistral if (inplas.eq. 94) jtestj=15 else if(jluc.eq.23) then if (formod(1).eq.'MELANGE ') then if (cmate.eq.'PARALLEL') jecree=0 endif else if(jluc.eq.26) then jecree = 0 endif nomid = mocomp if (nomid.le.0) return nobl = lesobl(/2) nfac = lesfac(/2) call cotype(iqmod,jluc,motype,iwrk53,nobl,nfac) notype = motype nbtype = 0 if (notype.NE.0) then nbtype = type(/2) ENDIF if (nbtype.ne.0) GOTO 200 * do jm =1,mobl dec1=pilobl(jm,2) if(dec1.eq.0) then dec1=pilobl(jm,1) endif if(FORMOD(1).EQ.'MELANGE '.and.cmate.eq.'PARALLEL' & .and.pilobl(jm,3).gt.0 ) dec1 = pilobl(jm,3) if (dec1.gt.0) then segini,deche=dec1 indec = irang ijlcon=ijlcon+1 if(ijlcon.gt.iilcon) then iilcon=iilcon+mobl+mfac segadj lilcon endif lilcon(ijlcon) = deche if (jecree.eq.1) then if (typree) then N1PTEL=NBPTEL N1EL=NEL N2PTEL=0 N2EL=0 else N2PTEL=NBPTEL N2EL=NEL N1PTEL=0 N1EL=0 endif segini melval ieldec = melval else c if (cmate.eq.'PARALLEL'.and.jluc.eq.23) c &write(6,*) 'deche imite',nomdec,ieldec,n1ptel,n1el,condec,jecree endif pilobl(jm,irang)= deche endif enddo do jm =1,mfac dec1=pilfac(jm,2) if (dec1.gt.0) then segini,deche=dec1 indec = irang ijlcon=ijlcon+1 if(ijlcon.gt.iilcon) then iilcon=iilcon+mfac segadj lilcon endif lilcon(ijlcon) = deche if(jecree.eq.1) then if (typree) then N1PTEL=NBPTEL N1EL=NEL N2PTEL=0 N2EL=0 else N2PTEL=NBPTEL N2EL=NEL N1PTEL=0 N1EL=0 endif segini melval ieldec = melval ** segdes melval endif ** segdes deche pilfac(jm,irang)= deche endif enddo GOTO 50 200 CONTINUE deche = lilcon(1) * n3 a revoir n3 = infdec(/1) ** segdes deche do 30 jm = 1, mobl dec1=pilobl(jm,irang-1) if(FORMOD(1).EQ.'MELANGE '.and.cmate.eq.'PARALLEL' & .and.pilobl(jm,3).gt.0 ) dec1 = pilobl(jm,3) if(dec1.eq.0) dec1=pilobl(jm,1) segini deche ijlcon=ijlcon+1 if( ijlcon.gt.iilcon) then iilcon=iilcon + mobl + mfac segadj lilcon endif lilcon(ijlcon) = deche pilobl(jm,irang)=deche nomdec = lesobl(jm) imadec = imamod ICMN=MIN(jm,NBTYPE) typdec = type(icmn) typree = typdec(1:6).eq.'REAL*8' condec = conmod ifodec = IFOUR indec = irang infdec(1) = 0 infdec(2) = 0 infdec(3) = NIFOUR infdec(4) = IPMINT infdec(5) = 0 infdec(6) = lesupp * if(jecree.eq.0) then if(jm.le.jtestj.and.jluc.eq.13)go to 356 if(dec1.ne.0) then ieldec = dec1.ieldec c if (cmate.eq.'PARALLEL'.and.jluc.eq.23) c &write(6,*) 'dec rep', nomdec, ieldec, deche,dec1.condec,dec1.indec go to 345 endif endif 356 continue if (type(icmn)(1:6).eq.'REAL*8') then N1PTEL=NBPTEL N1EL=NEL N2PTEL=0 N2EL=0 else N2PTEL=NBPTEL N2EL=NEL N1PTEL=0 N1EL=0 endif segini melval * write(6,*) 'cree ',nomdec,melval,n1ptel,n1el,condec ieldec = melval ** segdes melval 345 continue ** segdes deche 30 continue do 31 jm =1,mfac dec1=pilfac(jm,irang-1) if(dec1.eq.0) dec1=pilfac(jm,1) if (jluc.eq.20) then if (formod(1).eq.'LIAISON ') goto 340 * kich : composantes facultatives MODAL / STATIQUE else if (jluc.eq.11) then if (imatee.eq.9 .or. imatee.eq.10) goto 340 endif if(dec1.eq.0) go to 31 340 segini deche ijlcon=ijlcon+1 if(ijlcon.gt.iilcon) then iilcon = iilcon+mfac segadj lilcon endif lilcon(ijlcon) = deche pilfac(jm,irang)=deche nomdec = lesfac(jm) imadec = imamod ICMN=MIN(jm+nobl,NBTYPE) typdec = type(icmn) typree = typdec(1:6).eq.'REAL*8' condec = conmod ifodec = IFOUR indec = irang infdec(1) = 0 infdec(2) = 0 infdec(3) = NIFOUR infdec(4) = IPMINT infdec(5) = 0 infdec(6) = lesupp if(jecree.eq.0.and.dec1.gt.0) then C segact dec1 ieldec=dec1.ieldec ** segdes dec1 * write(6,*) 'dec fac rep', nomdec, ieldec, deche,condec go to 346 endif if (type(icmn)(1:6).eq.'REAL*8') then N1PTEL=NBPTEL N1EL =NEL N2PTEL=0 N2EL =0 else N2PTEL=NBPTEL N2EL =NEL N1PTEL=0 N1EL =0 endif * segini melval * write(6,*) 'cree fac',cmatee,nomdec,melvaln1ptel,n1el,condec ieldec = melval 346 continue 31 continue 50 CONTINUE segsup notype * if (iilcon.ne.ijlcon) then iilcon=ijlcon segadj lilcon endif END