C CONFIG SOURCE PV090527 25/06/04 21:15:01 12275 SUBROUTINE CONFIG C======================================================================= C OPERATEUR TRANSFORMANT DES CHAMPS DE CONTRAINTES/DEFORMATIONS SUR C LA CONFIGURATION COURANTE OU ACTUALISANT DES CHAMPS DE C CARACTERISTIQUES C C MCHAMA (MCHAMB ...) = 'CONF' MOD1 MCHAM1 (MCHAM2 ...) ; C C Entrees : C --------- C MOD1 : OBJET MODELE (TYPE MMODEL) C MCHAM1 : OBJET MCHAML DE CONTRAINTES OU DE DEFORMATIONS C MCHAM2 : OBJET MCHAML DE CONTRAINTES OU DE DEFORMATIONS C ... : OBJET MCHAML DE CONTRAINTES OU DE DEFORMATIONS C C Sorties : C --------- C MCHAMA : OBJET MCHAML TRANSFORME DE MCHAM1 C MCHAMB : OBJET MCHAML TRANSFORME DE MCHAM2 C ... : OBJET MCHAML TRANSFORME DE ... C C Remarque : la configuration courante est celle du MCOORD et la C configuration associee au MCHAML est celle stockee C a l'indice mclcnf C======================================================================= IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC SMMODEL -INC SMCHAML -INC SMCOORD -INC SMCHPOI -INC SMELEME POINTEUR MCHEX1.MCHELM C PARAMETER(NDERI=7) CHARACTER*4 MODERI(NDERI) DATA MODERI/'LINE','QUAD','I ','II ','TRUE','JAUM','UTIL'/ c -> IDERI = 1 2 1 2 3 4 5 c traitement particulier uniquement si IDERI = 4 ou 5 C LOGICAL CARACT SEGMENT IRESUL(0) C CHARACTER*(LOCOMP) NODEF(3),NODEG(3) CHARACTER*(LOCOMP) RODEF(3),RODEG(3) DATA NODEF / 'UX ','UY ','UZ ' / DATA NODEG / 'UR ','UZ ','UT ' / DATA RODEF / 'RX ','RY ','RZ ' / DATA RODEG / 'RR ','RZ ','RT ' / C----------------------------------------------------------------------- IPMODL=0 IPCHE1=0 IPCHE2=0 IPCHP1=0 *as xfem 2010_01_13 IPCHP0=0 ICHAX1=0 IDERI=MEPSIL C C LECTURE DU MMODEL C CALL LIROBJ('MMODEL ',IPMODL,1,IRT1) IF(IERR.NE.0) RETURN CALL ACTOBJ('MMODEL ',IPMODL,2) IF(IERR.NE.0)RETURN C MMODEL = IPMODL NBPART = KMODEL(/1) IPICA = 0 DO 4 IPART=1,NBPART IMODEL = KMODEL(IPART) C Pour certains modeles (OTTOSEN, UO2), les operateurs PICA et CAPI ne C doivent pas modifier les champs ! * septembre 2019: cette restriction est enlevee ** IF ( INATUU.EQ.42 .OR. INATUU.EQ.108 ) IPICA = IPICA+1 C Pour les modeles utilisateur UMAT, les contraintes sont deja de Cauchy C et ne doivent donc pas etre transportees ! IF ( INATUU.EQ.-1) IPICA = IPICA+1 C Verification presence XFEM *as xfem 2010_01_13 NOBMO1=IVAMOD(/1) if (NOBMO1.ne.0) then Do iobmo1=1,NOBMO1 if (TYMODE(iobmo1).eq.'MCHAML') then MCHEX1=IVAMOD(iobmo1) if (MCHEX1.TITCHE .eq. 'ENRICHIS') then ICHAX1 = MCHEX1.ICHAML(1) goto 3 endif endif Enddo endif 3 CONTINUE *fin as xfem 2010_01_13 4 CONTINUE IPICA = 0 C Presence XFEM -> pointeur ICHAX1 non nul *as xfem 2010_01_13 if (ichax1.ne.0 .and. ipchp0.EQ.0) then write(ioimp,*) 'pr un deplacement enrichi, on a besoin du ', & 'deplacement entre la config. 0 et la config. de reference' CALL ERREUR(21) return endif C C LECTURE DU(DES) MCHAML(S) A TRANSFORMER C SEGINI,IRESUL ICODE=1 C ------------------------------------------------------------------ 10 CONTINUE CALL LIROBJ('MCHAML ',IPIN,ICODE,IRT1) C IF (IERR.NE.0) RETURN IF (IRT1.EQ.0) GOTO 20 C C sauver les configuration et passage dans mclcnf pour le reduaf MCHELM=IPIN SEGACT MCHELM if(mclcnf.eq.0.or.mclcnf.eq.mcoord) then IPCHE2=IPIN GOTO 11 endif CALL ACTOBJ('MCHAML ',IPIN,2) IF(IERR.NE.0) RETURN mcoor1=mclcnf segact,mcoord,mcoor1 ** write (6,*) 'mclcnf mcoord avant reduag',mclcnf,mcoord * ici faire quelque chose pour que reduaf ne plante pas sur une erreur de configuration CALL REDUAG(IPIN,IPMODL,IPCHE1,0,IR,KER) C IF (IERR.NE.0) RETURN IF (IR .NE.1) CALL ERREUR(KER) C IPICA = NBPART -> Le modele entier contient des modeles UMAT C Recopie MCHAML IPCHE1 tel quel et on quitte IF (IPICA.EQ.NBPART) THEN CALL COPIE8(IPCHE1,IPCHE2) GOTO 11 ENDIF C C Presence de caracteristiques a actualiser MCHELM=IPCHE1 caract=(titche.eq.'CARACTERISTIQUES') C----------------------------------------------------------------------- C LECTURE D'UN CHPOINT DE DEPLACEMENTS C----------------------------------------------------------------------- CALL LIROBJ('CHPOINT ',IPCHP1,0,IRETOU) C IF (IRETOU.NE.0) THEN mchpoi=ipchp1 call actobj('CHPOINT',mchpoi,2) ELSE C Construire le chpoint de deplacements permettant de passer de la C configuration associee au MCHAML (mcoor1) a celle courante (mcoord) NAT=2 NSOUPO=1 SEGINI MCHPOI ipchp1=mchpoi mtypoi='config' ifopoi=ifour jattri(1)=1 C mrotat=mrota mrota1=mcoor1.mrota idimr=3 if (mrotat.ne.0.or.mrota1.ne.0) call oooprl(1) if (mrotat.ne.0) then segact mrotat if (xrota(/1).ne.idimr.or.xrota(/2).ne.nbpts) then segadj mrotat segdes mrotat endif endif if (mrota1.ne.0) then segact mrota1 if (mrota1.xrota(/1).ne.idimr.or.mrota1.xrota(/2).ne.nbpts) then segadj mrota1 endif endif if(mrotat.ne.0) segact mrotat if (mrotat.ne.0.or.mrota1.ne.0) call oooprl(0) C nct=3 ncr=3 nc=nct+ncr SEGINI MSOUPO ipchp(1)=msoupo if (ifour.ne.0.and.ifour.ne.1) then do i=1,nct nocomp(i)=nodef(i) enddo do i=nct+1,nc nocomp(i)=rodef(i-nct) enddo else do i=1,nct nocomp(i)=nodeg(i) enddo do i=nct+1,nc nocomp(i)=rodeg(i-nct) enddo endif C N=nbpts segini mpoval ipoval=mpoval nbpts1=mcoor1.xcoor(/1)/(idim+1) ** write(6,*) 'config nbpts nbpts1',nbpts,nbpts1 do i=1,min(nbpts,nbpts1) do j=1,nct ij=(i-1)*(idim+1)+j vpocha(i,j)=xcoor(ij)-mcoor1.xcoor(ij) enddo do j=1,ncr jj=j+nct if(mrota.ne.0.and.mrota1.ne.0) then vpocha(i,jj)=xrota(j,i)-mrota1.xrota(j,i) elseif(mrota.ne.0.and.mrota1.eq.0) then vp =xrota(j,i) vpocha(i,jj)=vp elseif(mrota.eq.0.and.mrota1.ne.0) then vpocha(i,jj)= -mrota1.xrota(j,i) endif enddo enddo do i=min(nbpts,nbpts1)+1,nbpts do j=1,nct ij=(i-1)*(idim+1)+j vpocha(i,j)=xcoor(ij) enddo enddo if(mrota.ne.0) then do i=min(nbpts,nbpts1)+1,nbpts do j=1,ncr jj=j+nct vpocha(i,jj)=xrota(j,i) enddo enddo endif C if (mrota1.ne.0) segdes mrota1 if (mrotat.ne.0) segdes mrotat C if (.not.caract) then do i=1,nbpts do j=1,nc vpocha(i,j)=-vpocha(i,j) enddo enddo endif C nbnn=1 nbelem=nbpts nbsous=0 nbref=0 segini meleme itypel=1 do i=1,nbelem num(1,i)=i enddo igeoc=meleme endif ** segact mchpoi ** call ecchpo(mchpoi,0) C segact mchelm*mod IF (.NOT.CARACT) THEN ** write (6,*) 'mcoors mcoord avant piocap',mcoors,mcoord,mchelm mclcnf=mcoord ** segact mcoord nbpts=xcoor(/1)/(idim+1) CALL PIOCAP(IPMODL,IPCHE1,IPCHP1,IPCHP0,ICHAX1,1,IDERI, & IPCHE2,IRET) mchelm=ipche2 ** write (6,*) 'mclcnf mcoord apres piocap',mclcnf,mcoord,mchelm ELSE C Mise a jour des caracteristiques materielles ** write (6,*) 'mclcnf mcoord avant formch',mclcnf,mcoord,mchelm CALL FORMCH(IPMODL,IPCHE1,IPCHP1,iret,IPCHE2,mcoor1) mchelm=ipche2 segact mchelm*mod mclcnf=mcoord ** write (6,*) 'mclcnf mcoord apres formch',mclcnf,mcoord,mchelm ENDIF segact mcoord nbpts=xcoor(/1)/(idim+1) segdes,mcoord,mcoor1 ** call verrou(3) C 11 CONTINUE IRESUL(**)=IPCHE2 C ICODE = 0 GOTO 10 C ------------------------------------------------------------------ C Ecriture du(des) objet(s) resultat(s) 20 CONTINUE C INBC=IRESUL(/1) DO IE=1,INBC IPCHE3=IRESUL(INBC+1-IE) CALL ACTOBJ('MCHAML ',IPCHE3,2) CALL ECROBJ('MCHAML ',IPCHE3) ENDDO SEGSUP,IRESUL C C Suppression du chpoint cree if (iretou.eq.0) then do isp=1,ipchp(/1) msoupo=ipchp(isp) mpoval=ipoval segsup mpoval meleme=igeoc segsup meleme segsup msoupo enddo segsup mchpoi endif END