C KDOM4C SOURCE CHAT 05/01/13 00:54:19 5004 SUBROUTINE KDOM4C(MELF,MELFL,MELFP,MCHPSU,MCHPNO,MCHPMR) C C************************************************************************ C C PROJET : CASTEM 2000 C C NOM : KDOM4C C Subroutine called by KDOM4A C Axial-symmetric case, TRI7 and QUA8 C We compute C MTAB . 'XXSURFAC' C MTAB . 'XXNORMAF' C MTAB . 'MATROT' C and we change the position for the central points C of MELEMQ C C LANGAGE : FORTRAN 77 + ESOPE 2000 (avec estensions CISI) C C AUTEUR : A. BECCANTINI, DRN/DMT/SEMT/LTMF C C C************************************************************************ C C INPUTS : C C MELF : meleme 'FACE' C MELFL : meleme 'FACEL' C MELFP : meleme 'FACEP' C C OUTPUTS : C C MCHPSU : mchpoi 'XXSURFAC' C MCHPNO : mchpoi 'XXNORMAF' C MCHPMR : mchpoi 'MATROT' C C*********************************************************** C C Created the 24/02/04 C C**** Variables of CCOPTIO C C INTEGER IPLLB, IERPER, IERMAX, IERR, INTERR C & ,IOTER, IOLEC, IOIMP, IOCAR, IOACQ C & ,IOPER, IOSGB, IOGRA, IOSAU, IORES C & ,IECHO, IIMPI, IOSPI C & ,IDIM CC & ,MCOORD C & ,IFOMOD, NIFOUR, IFOUR, NSDPGE, IONIVE C & ,NGMAXY, IZROSF, ISOTYP, IOSCR,LTEXLU C & ,NORINC,NORVAL,NORIND,NORVAD C & ,NUCROU, IPSAUV, IFICLE, IPREFI, IREFOR, ISAFOR C IMPLICIT INTEGER(I-N) INTEGER IGEOM, MCHPSU, MCHPNO, MCHPMR & ,JGN, JGM, NP, NEL, IEL, NLCF & , NF, IP1, IP2 REAL*8 X1,X2,Y1,Y2,SURF,XF,YF,DX,DY,DVAL,DNX,DNY,DTX,DTY,ORIENT CHARACTER*8 TYPE -INC CCOPTIO -INC SMELEME POINTEUR MELFL.MELEME,MELFP.MELEME,MELF.MELEME -INC SMCHPOI POINTEUR MPOVSU.MPOVAL, MPOVNO.MPOVAL, MPOVMR.MPOVAL -INC SMLENTI -INC SMLMOTS -INC SMCOORD C C**** Corresp. FACE C CALL KRIPAD(MELF,MLENTI) C SEGINI MLENTI C C**** Champoint surfaces C JGN=4 JGM=1 SEGINI MLMOTS MLMOTS.MOTS(1)='SCAL' TYPE='FACE ' CALL KRCHP1(TYPE,MELF,MCHPSU,MLMOTS) IF(IERR.NE.0)GOTO 9999 CALL LICHT(MCHPSU,MPOVSU,TYPE,IGEOM) IF(IERR.NE.0)GOTO 9999 C SEGACT MPOVSU SEGSUP MLMOTS C C**** Champoint normales C JGN=4 JGM=IDIM SEGINI MLMOTS MLMOTS.MOTS(1)='UX' MLMOTS.MOTS(2)='UY' TYPE='FACE ' CALL KRCHP1(TYPE,MELF,MCHPNO,MLMOTS) IF(IERR.NE.0)GOTO 9999 CALL LICHT(MCHPNO,MPOVNO,TYPE,IGEOM) IF(IERR.NE.0)GOTO 9999 C SEGACT MPOVNO SEGSUP MLMOTS C C**** Champoint matrice de rotation C JGN=4 JGM=IDIM*IDIM SEGINI MLMOTS C IF(IDIM.EQ.2)THEN MLMOTS.MOTS(1)='RX' MLMOTS.MOTS(2)='RY' MLMOTS.MOTS(3)='MX' MLMOTS.MOTS(4)='MY' * Normale en M * vect(M,U) = z C ENDIF CALL KRCHP1(TYPE,MELF,MCHPMR,MLMOTS) IF(IERR.NE.0)GOTO 9999 CALL LICHT(MCHPMR,MPOVMR,TYPE,IGEOM) IF(IERR.NE.0)GOTO 9999 C SEGACT MPOVMR C SEGACT MELFP C In the case 2D, NBSOUS=1 SEGACT MELFL C NP=MELFP.NUM(/1)-1 NEL=MELFP.NUM(/2) IF(NP .NE. 2)THEN WRITE(IOIMP,*) 'Subroutine kdom4c.eso' CALL ERREUR(5) ENDIF C DO IEL=1,NEL,1 C X1,Y1,X2,Y2,XF,YF NF=MELFP.NUM(NP+1,IEL) IP1=MELFP.NUM(1,IEL) IP2=MELFP.NUM(2,IEL) X1=XCOOR((IP1-1)*(IDIM+1)+1) Y1=XCOOR((IP1-1)*(IDIM+1)+2) X2=XCOOR((IP2-1)*(IDIM+1)+1) Y2=XCOOR((IP2-1)*(IDIM+1)+2) CALL KDOM3B(X1,Y1,X2,Y2,SURF,XF,YF) XCOOR((NF-1)*(IDIM+1)+1)=XF XCOOR((NF-1)*(IDIM+1)+2)=YF NLCF=MLENTI.LECT(NF) MPOVSU.VPOCHA(NLCF,1)=SURF DX=X1-XF DY=Y1-YF DVAL=((DX*DX)+(DY*DY))**0.5D0 DNX=DY/DVAL DNY=-1.0D0*DX/DVAL DTX=DX/DVAL DTY=DY/DVAL C C******* Orientation selon FACEL C IP1=MELFL.NUM(1,NLCF) X1=XCOOR((IP1-1)*(IDIM+1)+1) Y1=XCOOR((IP1-1)*(IDIM+1)+2) DX=XF-X1 DY=YF-Y1 ORIENT=SIGN(1.0D0,((DNX*DX)+(DNY*DY))) C MPOVNO.VPOCHA(NLCF,1)=DNX*ORIENT MPOVNO.VPOCHA(NLCF,2)=DNY*ORIENT C MPOVMR.VPOCHA(NLCF,3)=DNX*ORIENT MPOVMR.VPOCHA(NLCF,4)=DNY*ORIENT MPOVMR.VPOCHA(NLCF,1)=DTX*ORIENT MPOVMR.VPOCHA(NLCF,2)=DTY*ORIENT C ENDDO C SEGDES MPOVSU SEGDES MPOVNO SEGDES MPOVMR SEGDES MELFP C SEGDES MELFL SEGSUP MLENTI C 9999 RETURN END