C REDUIC SOURCE PV 20/03/26 21:16:19 10563 SUBROUTINE REDUIC ( IPCHE,IMEL,IRET) *______________________________________________________________________ * * redu d'un chamelem sur meleme (appele par redu) * * entrees : * --------- * ipche chamelem a reduire (type mchaml) * imel maillage sur lequel on doit reduire (type meleme) * * * sortie : * -------- * iret chamelem reduit * = 0 si pb * * * *______________________________________________________________________ * * declarations * IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC SMCHAML -INC SMELEME * CHARACTER*(NCONCH) CONST * * executable * IRET = 0 CONST = ' ' MCHELM = IPCHE SEGACT,MCHELM * Cas particulier du MCHAML vide : NZ = IMACHE(/1) IF (NZ.EQ.0) THEN SEGINI,MCHEL1=MCHELM ** SEGDES MCHELM,MCHEL1 IRET = MCHEL1 RETURN ENDIF MELEME = IMEL SEGACT MELEME NBSOUS = LISOUS(/1) IPT1 = IMEL * * boucle sur les maillages elementaires * DO 100 I=1,(MAX(1,NBSOUS)) IF (NBSOUS .NE. 0) THEN IPT1 = LISOUS(I) ENDIF CALL TESTMA(IPCHE,IPT1,.FALSE.,CONST,IRETOU,IMODI) * IF(IRETOU.EQ.0.AND.IERR.EQ.0) THEN CALL ERREUR(472) ENDIF MCHEL1 = IRETOU IF (IERR .NE. 0) THEN IF (IRETOU .NE. 0) THEN SEGSUP MCHEL1 ENDIF GOTO 990 ENDIF * * concatenation du resultat * IF (I .EQ. 1) THEN MCHELM = IRETOU N1 = IMACHE(/1) N3 = INFCHE(/2) L1 = TITCHE(/1) ELSE MCHEL1 = IRETOU NN1 = MCHEL1.IMACHE(/1) N1 = N1 + NN1 N3 = MAX(N3,MCHEL1.INFCHE(/2)) SEGADJ MCHELM DO 10 J=1,NN1 CONCHE(J+N1-NN1) = MCHEL1.CONCHE(J) IMACHE(J+N1-NN1) = MCHEL1.IMACHE(J) ICHAML(J+N1-NN1) = MCHEL1.ICHAML(J) DO 20 K=1,MCHEL1.INFCHE(/2) INFCHE(J+N1-NN1,K)=MCHEL1.INFCHE(J,K) 20 CONTINUE 10 CONTINUE SEGSUP MCHEL1 ENDIF * 100 CONTINUE * IRET = MCHELM ** SEGDES,MCHELM * 990 CONTINUE C MELEME = IMEL C MCHEL1 = IPCHE C SEGDES,MELEME,MCHEL1 * RETURN END