C RLEXC1 SOURCE CB215821 20/11/04 21:21:03 10766 SUBROUTINE RLEXC1(MLEPOI,MLECOE,MCHELM) C************************************************************************ C C PROJET : CASTEM 2000 C C NOM : RLEXC1 C C DESCRIPTION : Appelle par GRADI2 C C LANGAGE : FORTRAN 77 + ESOPE 2000 (avec extensions CISI) C C AUTEUR : A. BECCANTINI C C************************************************************************ C C Inputs: C C MLEPOI : pointers of list of points (FACE + neighbors) C C MLECOE : pointers of the list of coeff C C Output C C MCHELM : MCHAML which contains the coeff. to compute gradients C C C C**** Variables de COOPTIO 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 C & ,MCOORD C & ,IFOMOD, NIFOUR, IFOUR, NSDPGE, IONIVE C & ,NGMAXY, IZROSF, ISOTYP, IOSCR,LTEXLU C & ,NORINC,NORVAL,NORIND,NORVAD C & ,NUCROU, IPSAUV, IPREFI, IFICLE CC IMPLICIT INTEGER(I-N) INTEGER N1,N2 SEGMENT MATRIX REAL*8 MAT(N1,N2) ENDSEGMENT C -INC PPARAM -INC CCOPTIO INTEGER N3,L1,N1PTEL,N1EL,N2PTEL,N2EL INTEGER NBNN,NBELEM,NBSOUS,NBREF INTEGER JG -INC SMCHAML -INC SMLREEL -INC SMLENTI -INC SMELEME POINTEUR MLELAS.MLENTI, MLECON.MLENTI, MLEELT.MLENTI & ,MLEPOI.MLENTI,MLECOE.MLENTI C INTEGER NFAC,NMAX,IFAC, NTSOUS, I1, NBNN0, I3, I2, NG, ISOUS C SEGACT MLEPOI SEGACT MLECOE NFAC=MLEPOI.LECT(/1) C C**** NMAX = maximum number of points in the element C 'FACE'-neighbors NMAX=0 DO IFAC = 1, NFAC, 1 MLENTI=MLEPOI.LECT(IFAC) SEGACT MLENTI NBNN=MLENTI.LECT(/1) NMAX=MAX(NMAX,NBNN) ENDDO C C**** We create the following MLENTI C C MLECON : dimension = NMAX C MLECON.LECT(I) = number of elements with I points C C MLELAS : dimension = NMAX C MLELAS.LECT(I) = 0 -> there are no elements with I C points C C J -> the J-th element has I points C C C The other elements with I points are into the chaining list C MLEELT. C C MLEELT : dimension = NFAC C MLEELT+MLELAS allows to rapidly recover the elements C with the same number of points C For example, the elements with I points are: C IELEM = MLELAS.LECT(I) C IELEM2 = MLEELT.LECT(IELEM) C ... C IELEM_K+1 = MLEELT.LECT(IELEM_K) C ... C until IELEM_K+1 = 0 C JG=NMAX SEGINI MLELAS SEGINI MLECON JG=NFAC SEGINI MLEELT DO IFAC = 1, NFAC, 1 MLENTI=MLEPOI.LECT(IFAC) NBNN=MLENTI.LECT(/1) MLECON.LECT(NBNN)=MLECON.LECT(NBNN)+1 MLEELT.LECT(IFAC)= MLELAS.LECT(NBNN) MLELAS.LECT(NBNN)=IFAC ENDDO C C**** Les supports C NTSOUS=0 DO ISOUS=1,NMAX,1 IF(MLECON.LECT(ISOUS).NE.0) NTSOUS=NTSOUS+1 ENDDO C C**** Initialisation du MCHELM C N1=NTSOUS N2=IDIM N3=6 L1=8 SEGINI MCHELM MCHELM.TITCHE='Gradient' MCHELM.IFOCHE=IFOUR C ISOUS=0 NBSOUS=0 NBREF=0 DO I1 = 1, NMAX, 1 NBELEM=MLECON.LECT(I1) IF(NBELEM .GT. 0)THEN ISOUS=ISOUS+1 NBNN=I1 SEGINI MELEME C ITYPEL=32 -> 'POLY' ITYPEL=32 MCHELM.IMACHE(ISOUS)=MELEME SEGINI MCHAML MCHELM.ICHAML(ISOUS)=MCHAML MCHAML.NOMCHE(1)='alphax' MCHAML.NOMCHE(2)='alphay' MCHAML.TYPCHE(1)='REAL*8 ' MCHAML.TYPCHE(2)='REAL*8 ' N1PTEL=NBNN N1EL=NBELEM N2PTEL=0 N2EL=0 SEGINI MELVA1 SEGINI MELVA2 MCHAML.IELVAL(1)=MELVA1 MCHAML.IELVAL(2)=MELVA2 IF(IDIM.EQ.3)THEN MCHAML.NOMCHE(3)='alphaz' MCHAML.TYPCHE(3)='REAL*8 ' SEGINI MELVA3 MCHAML.IELVAL(3)=MELVA3 ENDIF IFAC=MLELAS.LECT(I1) MLENTI=MLEPOI.LECT(IFAC) MATRIX=MLECOE.LECT(IFAC) SEGACT MATRIX NBNN0=MLENTI.LECT(/1) IF(NBNN0.NE.NBNN)THEN WRITE(IOIMP,*) 'subroutine rlexc1.eso' CALL ERREUR(5) GOTO 9999 ENDIF C C********** The first point of MLENTI is a FACE point C In the same way, MELEME.NUM(1,*) is the FACE point C C N.B. the first element is stored into MLELAS C the others are stored into MLEELT C DO I3=1,NBNN,1 NG=MLENTI.LECT(I3) MELEME.NUM(I3,1)=NG MELVA1.VELCHE(I3,1)=MATRIX.MAT(2,I3) MELVA2.VELCHE(I3,1)=MATRIX.MAT(3,I3) IF(IDIM.EQ.3) MELVA3.VELCHE(I3,1)=MATRIX.MAT(4,I3) ENDDO SEGSUP MLENTI SEGSUP MATRIX C DO I2=2,NBELEM,1 IFAC=MLEELT.LECT(IFAC) MLENTI=MLEPOI.LECT(IFAC) MATRIX=MLECOE.LECT(IFAC) SEGACT MATRIX NBNN0=MLENTI.LECT(/1) IF(NBNN0.NE.NBNN)THEN WRITE(IOIMP,*) 'subroutine rlexc1.eso' CALL ERREUR(5) GOTO 9999 ENDIF C DO I3=1,NBNN,1 NG=MLENTI.LECT(I3) MELEME.NUM(I3,I2)=NG MELVA1.VELCHE(I3,I2)=MATRIX.MAT(2,I3) MELVA2.VELCHE(I3,I2)=MATRIX.MAT(3,I3) IF(IDIM.EQ.3) MELVA3.VELCHE(I3,I2)=MATRIX.MAT(4,I3) ENDDO SEGSUP MLENTI SEGSUP MATRIX ENDDO C IFAC=MLEELT.LECT(IFAC) IF(IFAC.NE.0)THEN WRITE(IOIMP,*) 'subroutine rlexc1.eso' CALL ERREUR(5) GOTO 9999 ENDIF SEGDES MCHAML SEGDES MELEME SEGDES MELVA1 SEGDES MELVA2 IF(IDIM.EQ.3) SEGDES MELVA3 ENDIF ENDDO C SEGDES MCHELM C SEGSUP MLEPOI SEGSUP MLECOE SEGSUP MLEELT SEGSUP MLECON SEGSUP MLELAS C 9999 RETURN END C