C CHAME1 SOURCE GOUNAND 13/08/01 21:15:00 7810 SUBROUTINE CHAME1(IPMAIL,IPMODL,IPCHPO,CHA,IPCHEL,ISUP) *____________________________________________________________________* * * * transformation de chpoint en mchaml * * * * entr{es: * * ________ * * * * ipmail pointeur sur un maillage * * ou ipmodl pointeur sur un mmodel * * ipchpo pointeur sur le chpoint * * cha chaine de caract}re contenant un sous type eventuel * isup indique le type de support demande : * * 1 le mchaml est laisse aux noeuds * * 2 au centre de gravite * * 3 aux points de gauss de la raideur * * 4 aux points de gauss de la masse * * 5 aux points de gauss des contraintes * * 6 aux point de gauss de la thermique * * * * sorties: * * ________ * * * * ipchel pointeur sur le mchaml r{sultat * * * * remarque : le passage du mchaml sur un autre support que les * * noeuds n'est possible que si l'on a donne un mmodel * * * *____________________________________________________________________* * * IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC CCOPTIO -INC CCGEOME -INC SMCHAML -INC SMCHPOI -INC SMINTE -INC SMMODEL -INC SMELEME * SEGMENT INFO INTEGER INFELL(JG) ENDSEGMENT * CHARACTER*(*) CHA CHARACTER*(NCONCH) CONM LOGICAL FLAG1 LOGICAL FLAG3 LOGICAL FLAG4,ltelq * * soutyp = sous-type du champ par element resultat * lsouty = longueur utile de la chaine "soutyp" * INTEGER LSOUTY CHARACTER*72 SOUTYP * * le traitement d'harmoniques de fourier n'est pas implemente * ISUP1=ISUP IPCHEL=0 NPINT = 0 IRRT=0 CONM=' ' * * on cree l'objet maillage contenant tous les points du chpoint * MCHPOI=IPCHPO SEGACT,MCHPOI NSOUPO=IPCHP(/1) IPGEOM = 0 * cette boucle meriterai d'etre reecrite : elle est pitoyable DO 1140 I=1,NSOUPO MSOUPO=IPCHP(I) SEGACT MSOUPO IF (IPGEOM.EQ.0) THEN IPGEOM = IGEOC ELSE IPP2 = IGEOC ltelq=.false. CALL FUSE (IPGEOM,IPP2,IRET,ltelq) * il faut détruire les intermédiaires IF ( I .GT. 2 ) THEN IPT3 = IPGEOM SEGdes IPT3 ENDIF IPGEOM = IRET ENDIF 1140 CONTINUE * N3=6 IF (IPMAIL.NE.0) THEN IPT1=IPMAIL SEGACT,IPT1 NSOUS=IPT1.LISOUS(/1) IF (NSOUS.EQ.0) THEN NSOUS=1 ENDIF ISUP1=1 ELSE IF (IPMODL.NE.0) THEN MMODEL = IPMODL SEGACT,MMODEL NSOUS = KMODEL(/1) IF (ISUP1.GT.1) N3=6 ENDIF * * initialisation du segment descripteur du champ par element * N1=NSOUS IF (CHA.EQ.' ') THEN L1=8 SOUTYP=MTYPOI ELSE L1=LEN(CHA) SOUTYP=CHA ENDIF SEGINI,MCHELM TITCHE=SOUTYP IFOCHE=IFOUR * * boucle sur les zones geometriques elementaires * isouss=0 DO 20 ISOUS=1,NSOUS ISUP1 = ISUP IPMINT=0 IF (IPMAIL.NE.0) THEN IF (NSOUS.GT.1) THEN ITGEOM=IPT1.LISOUS(ISOUS) ELSE ITGEOM=IPMAIL ENDIF ELSE IF (IPMODL.NE.0) THEN IMODEL = KMODEL(ISOUS) SEGACT,IMODEL if( nefmod.eq.22) then segdes imodel go to 20 endif ITGEOM = IMAMOD if (formod(1).eq.'LIAISON') then * ne fait rien si le support liaison n appartient pas au CHPOINT ipt1 = imamod segact ipt1 meleme =ipgeom segact meleme do jno = 1, num(/2) if (num(1,jno).eq.ipt1.num(1,1)) goto 11 enddo segdes,ipt1 goto 20 endif 11 CONM = CONMOD IF(INFMOD(/1).NE.0) NPINT=INFMOD(1) * * Changment de support si besoin selon la formulation ? IF (ISUP1 .NE. 1) THEN NFOR = FORMOD(/2) C* Modele de Frottement ? CALL PLACE(FORMOD,NFOR,ifro,'FROTTEMENT') IF (ifro.NE.0) THEN ISUP1 = 1 C* Modele de THERMIQUE ? ELSE CALL PLACE(FORMOD,NFOR,ither,'THERMIQUE') IF (ither.NE.0) THEN nmat = matmod(/2) icov = 0 C* CALL PLACE(matmod,nmat,icov,'CONVECTION') CALL PLACE(matmod,nmat,iray,'RAYONNEMENT') IF (icov+iray.EQ.0) ISUP1 = 6 ENDIF ENDIF ENDIF * * on recupere le pointeur sur le minte correspondant a isup1 * IF (ISUP1.GT.1) THEN MELE=NEFMOD IF ( ISUP1 .EQ. 6) THEN * cas de la thermique CALL TSHAPE(MELE,'GAUSS',IPMINT) IF (IERR.NE.0) THEN SEGDES,MCHPOI IF (IPMAIL.NE.0) SEGDES,IPT1 IF (IPMODL.NE.0) SEGDES,MMODEL SEGDES,IMODEL SEGSUP,MCHELM RETURN ENDIF IELE = NUMGEO(MELE) NBNN = NBNNE(IELE) ELSE C* segact imodel if(2+isup1.gt.infmod(/1)) then CALL ELQUOI (MELE,0,ISUP1,IPINF,IMODEL) IF (IERR.NE.0) THEN SEGDES,MCHPOI IF (IPMAIL.NE.0) SEGDES,IPT1 IF (IPMODL.NE.0) SEGDES,MMODEL SEGDES,IMODEL SEGSUP,MCHELM RETURN ENDIF INFO=IPINF IPMINT=INFELL(11) * SEGSUP,INFO else ipmint=infmod(2+isup1) IELE =INFELE(14) NBNN =NBNNE(IELE) endif * write(6,*) ' chame1 ipmint iele nbnn',ipmint,iele,nbnn ENDIF * * initialisation de ipore pour milieu poreux * IPORE=0 IF(MELE.GE.79.AND.MELE.LE.83) IPORE=NBNN ***** IF(MELE.GE.108.AND.MELE.LE.110) IPORE=NBNN IF(MELE.GE.173.AND.MELE.LE.177) IPORE=NBNN ***** IF(MELE.GE.185.AND.MELE.LE.187) IPORE=NBNN IF(MELE.GE.178.AND.MELE.LE.182) IPORE=NBNN ***** IF(MELE.GE.188.AND.MELE.LE.190) IPORE=NBNN * cas XFEM il faut seulement les 4 premier noeuds (support geometrique) IF(MELE.GE.263) IPORE=NBNN * ELSE IPMINT=0 ENDIF SEGDES,IMODEL ENDIF isouss=isouss+1 * * projection du chpoint vers le chamelem,selon le * maillage considere * ICHAML(ISOUSs)=0 MINTE=IPMINT IF (IPMINT.NE.0) SEGACT,MINTE * write(6,*) ' chame1 : avant appel a chame2' CALL CHAME2(itgeom,MCHPOI,MCHELM,IPCHAM,IPMINT,IPORE) * write(6,*) ' chame1 : apres appel a chame2' IF (IPCHAM.EQ.0) THEN MOTERR(1:8)='MAILLAGE' MOTERR(9:16)='CHPOINT' CALL ERREUR(135) SEGDES,MCHPOI IF (IPMAIL.NE.0) SEGDES,IPT1 IF (IPMODL.NE.0) SEGDES,MMODEL IF (IPMINT.NE.0) SEGDES,MINTE SEGSUP,MCHELM RETURN ENDIF ICHAML(ISOUSs)=IPCHAM IMACHE(ISOUSs)=ITGEOM CONCHE(ISOUSs)=CONM INFCHE(ISOUSs,1)=0 INFCHE(ISOUSs,2)=0 INFCHE(ISOUSs,3)=NIFOUR INFCHE(ISOUSs,6)=ISUP1 IF (ISUP1.GT.1) THEN INFCHE(ISOUSs,4)=IPMINT INFCHE(ISOUSs,5)=0 ENDIF * * cas integration dans l'epaisseur avec variable t temperature. * on transforme tinf t tsup en t défini par une variation * parabolique dans l'epaisseur. si il n'y a que t on ne fait rien. * Ce travail n'est a faire que pour les elements DKT, COQ4, COQ6 et COQ8 * et uniquement si le MCHAML resultat n'est pas exprime aux noeuds ! * IF (ISUP1.NE.1) THEN IF ( (MELE.EQ.28.AND.NPINT.NE.0) .OR. (MELE.EQ.49) .OR. & (MELE.EQ.56) .OR. (MELE.EQ.41) ) THEN MCHAML = IPCHAM SEGACT MCHAML FLAG1 = .FALSE. FLAG3 = .FALSE. FLAG4 = .FALSE. DO 21 ISOU1 = 1,NOMCHE(/2) IF(NOMCHE(ISOU1).EQ.'T ') FLAG1 = .TRUE. IF(NOMCHE(ISOU1).EQ.'TINF ') FLAG3 = .TRUE. IF(NOMCHE(ISOU1).EQ.'TSUP ') FLAG4 = .TRUE. 21 CONTINUE IF (FLAG1.AND.FLAG3.AND.FLAG4) THEN MELEME = IMACHE(ISOUS) CALL CHAME4(IPCHAM,IPMINT,MELEME) ENDIF SEGDES MCHAML ENDIF ENDIF IF (IPMINT.NE.0) SEGDES,MINTE * 20 CONTINUE * * fin de la boucle sur mes zones élémentaires * IF (IRRT.EQ.NSOUS) THEN * * l'objet maillage et le chpoint sont incompatibles * MOTERR(1:8)='MAILLAGE' MOTERR(9:16)='CHPOINT' CALL ERREUR(135) SEGDES,MCHPOI IF (IPMAIL.NE.0) SEGDES,IPT1 IF (IPMODL.NE.0) SEGDES,MMODEL SEGSUP,MCHELM RETURN ENDIF * * ménage des segments * IF (IPMAIL.NE.0) SEGDES,IPT1 IF (IPMODL.NE.0) SEGDES,MMODEL if( n1.ne.isouss) then n1=isouss segadj mchelm endif IPCHEL=MCHELM SEGDES,MCHELM * on détruit le maillage total du champoint si il est forme de plusieurs * morceaux IF (IPCHP(/1) .GT. 1) THEN IPT3 = IPGEOM SEGDES IPT3 ENDIF * desactiver le champ par point DO 300 ISOUS=1,IPCHP(/1) MSOUPO=IPCHP(ISOUS) MPOVAL=IPOVAL SEGDES,MPOVAL MELEME=IGEOC SEGDES,MELEME SEGDES,MSOUPO 300 CONTINUE SEGDES,MCHPOI RETURN END