C REDU SOURCE PV090527 25/01/10 21:15:07 12111 SUBROUTINE REDU C_______________________________________________________________________ C C SUBROUTINE de l'operateur REDU qui aiguille suivant la fonctionnalite C_______________________________________________________________________ C C declaration C IMPLICIT REAL*8(A-H,O-Z) IMPLICIT INTEGER(I-N) -INC PPARAM -INC CCOPTIO -INC SMELEME -INC SMNUAGE -INC SMLMOTS -INC SMTABLE -INC SMCHAML -INC SMMODEL INTEGER I,NCOMP,J,IPO,INUA CHARACTER*4 IMO,charre,MO4a,MO4b LOGICAL logr1 CHARACTER*8 TYPOBJ character*4 mostri(1) data mostri/'STRI'/ C C executable C C ith=oothrd C C a-t'on en entrée une table esclave si oui on fusionne C C a-t'on le mot strict? istric=0 call lirmot(mostri,1,istric,0) C call lirtab('ESCLAVE',mtable,0,iretou) if(iretou.ne. 0) then C write(6,*) ' on fusionne la table esclave' typobj=' ' segact mtable ml=mlotab ind=mtabii(3) call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,typobj,ivalre, > xvalre,charre,logr1,id1) if (ierr.ne.0) return C if (typobj.eq.'CHPOINT'.or.typobj.eq.'MCHAML')then if (typobj.eq.'MCHAML ')then do i=4,ml segact mtable ind=mtabii(i) call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0, & typobj,ivalre,xvalre,charre,logr1,id2) if (ierr.ne.0) return C if (typobj.eq.'CHPOINT') call fuchpo(id1,id2,iretou) if (typobj.eq.'MCHAML ') call fuschl(id1,id2,iretou) id1=iretou enddo else C write (6,*) ' type ',typobj,' inconnu dans redu ' C call trbac MOTERR(1:8)='PARA ' call erreur(803) return endif CALL ACTOBJ(typobj,id1,1) CALL ECROBJ(typobj,id1) C write(6,*)' on a crée un objet ' , typobj endif C C reduction d'une rigidite sur un maillage C CALL LIROBJ('RIGIDITE',IPrigi,0,IRETOU) IF(IRETOU.EQ.0) GOTO 10 CALL LIROBJ('MAILLAGE',IMEL,1,IRETOU) CALL ACTOBJ('MAILLAGE',IMEL,1) IF(IRETOU.EQ.0) return call reduri(iprigi,imel,irig1) if(irig1.eq.0) return call ECROBJ('RIGIDITE', irig1) return 10 CONTINUE C C redu d'un chpoint sur (meleme ou point) C CALL LIROBJ('CHPOINT ',ICHP,0,IRETOU) IF(IRETOU.EQ.0) GO TO 1 CALL ACTOBJ('CHPOINT ',ICHP,1) CALL LIROBJ('MAILLAGE',IMEL,0,IRETOU) IF(IRETOU .EQ. 1) THEN CALL ACTOBJ('MAILLAGE',IMEL,1) ELSE CALL LIROBJ('POINT',IP1,0,IRETOU) IF (IRETOU.NE.0) THEN IMEL=IP1 CALL CRELEM(IMEL) ELSE CALL REFUS GO TO 1 ENDIF ENDIF CALL REDUIR(ICHP,IMEL,IRET) IF ( IERR .NE. 0) RETURN CALL ACTOBJ('CHPOINT ',IRET,1) CALL ECROBJ('CHPOINT ',IRET) RETURN C 1 CONTINUE C C redu mchaml sur meleme (ou point) C CALL LIROBJ('MCHAML ',ICHE,0,IRETOU) IF(IRETOU.EQ.0) GOTO 2 CALL ACTOBJ('MCHAML ',ICHE,1) CALL LIROBJ('MAILLAGE',IMEL,0,IRETOU) IF(IRETOU .EQ. 1)THEN CALL ACTOBJ('MAILLAGE',IMEL,1) ELSE CALL LIROBJ('POINT',IP1,0,IRETOU) IF (IRETOU.NE.0) THEN NBNN=1 NBELEM=1 NBREF=0 NBSOUS=0 SEGINI MELEME ITYPEL=1 NUM(1,1)=IP1 IMEL=MELEME ELSE CALL REFUS GOTO 2 ENDIF ENDIF CALL REDUIC(ICHE,IMEL,IRET) IF ( IERR .NE. 0) RETURN CALL ACTOBJ('MCHAML ',IRET,1) CALL ECROBJ('MCHAML ',IRET) RETURN C 2 CONTINUE C C redu chamelem sur mmodel C CALL LIROBJ('MCHAML ',ICHE,0,IRETOU) IF(IRETOU.EQ.0) GOTO 3 CALL ACTOBJ('MCHAML ',ICHE ,1) CALL LIROBJ('MMODEL ',IPMODL,0,IRETOU) C Derniere syntaxe avec MCHAML, si pas MMODEL, sortie erreur IF (IRETOU.EQ.0) THEN CALL REFUS GOTO 3 ENDIF CALL ACTOBJ('MMODEL',IPMODL,1) ** write(6,*) 'avant reduaf ipchm ',ipchm CALL REDUAF(ICHE,IPMODL,IPCHM,ISTRIC,IRET,KERRE) IF (ierr.ne.0) return ** write(6,*) 'apres reduaf ipchm ',ipchm IF ( IRET .NE. 1) THEN CALL ERREUR(KERRE) RETURN ENDIF CALL ACTOBJ('MCHAML ',ICHE ,1) CALL ACTOBJ('MCHAML ',IPCHM,1) CALL ECROBJ('MCHAML ',IPCHM) RETURN C 3 CONTINUE C C redu chpoint sur masq C CALL LIROBJ('CHPOINT ',ICHP,0,IRETOU) IF(IRETOU.EQ.0) GO TO 4 CALL ACTOBJ('CHPOINT ',ICHP,1) CALL LIROBJ('CHPOINT ',ICHP1,0,IRETOU) IF(IRETOU.EQ.0) THEN CALL REFUS GO TO 4 ENDIF CALL ACTOBJ('CHPOINT ',ICHP1,1) CALL REDUCP(ICHP,ICHP1,IRET) IF(IERR.NE.0) RETURN CALL ACTOBJ('CHPOINT ',IRET,1) CALL ECROBJ('CHPOINT ',IRET) RETURN C 4 CONTINUE C C redu mmodel sur meleme ou point ou reduit le model de contatct C au element qui peuvent etre actifs C CALL LIROBJ('MMODEL ',IPMODL,0,IRETOU) IF(IRETOU.EQ.0) GOTO 5 CALL ACTOBJ('MMODEL ',IPMODL,1) CALL LIRCHA(charre,0,ireto) if(ireto.ne.0) then if( charre.ne.'CONT' ) then call refus else call redcon(ipmodl,iret) call ACTOBJ('MMODEL ',iret,1) call ECROBJ('MMODEL ',iret) return endif endif CALL LIROBJ('MAILLAGE',IMEL,0,IRETOU) IF(IRETOU.EQ.1) THEN CALL ACTOBJ('MAILLAGE',IMEL,1) ELSE CALL LIROBJ('POINT',IP1,0,IRETOU) IF (IRETOU.NE.0) THEN NBNN=1 NBELEM=1 NBREF=0 NBSOUS=0 SEGINI MELEME ITYPEL=1 NUM(1,1)=IP1 IMEL=MELEME ELSE CALL REFUS GOTO 5 ENDIF ENDIF CALL REDUMO(IPMODL,IMEL,IRET) IF (IRET.NE.0) THEN CALL ACTOBJ('MMODEL ',IRET,1) CALL ECROBJ('MMODEL ',IRET) ENDIF RETURN C 5 CONTINUE C C REDU d'un nuage a des composantes C JGM = 0 JGN = 4 NCOMP = 0 IPO1 = 0 100 CONTINUE CALL LIRCHA(IMO,0,IRETOU) IF (IRETOU .EQ. 0) THEN IF(NCOMP .EQ. 0) THEN GOTO 6 ELSE GOTO 101 ENDIF ENDIF NCOMP = NCOMP + 1 IF (NCOMP .GT. JGM) THEN JGM = NCOMP*2 + 10 IF(IPO1 .EQ. 0)THEN SEGINI,MLMOTS IPO1 = MLMOTS ELSE SEGADJ,MLMOTS ENDIF ENDIF MLMOTS.MOTS(NCOMP) = IMO GOTO 100 101 CONTINUE DO 200 I = 1,NCOMP MO4a = MOTS(I) DO 201 J = (I + 1),NCOMP MO4b = MOTS(J) IF (MO4a.EQ.MO4b) THEN CALL ERREUR(674) RETURN ENDIF 201 CONTINUE 200 CONTINUE CALL LIROBJ('NUAGE ',INUA,0,IRETOU) IF (IRETOU.EQ.0) GOTO 6 CALL ACTOBJ('NUAGE ',INUA,1) CALL REDNUA(INUA,IPO1,NCOMP,INUAR,IRET) IF (IRET.NE.0) THEN CALL ACTOBJ('NUAGE ',INUAR,1) CALL ECROBJ('NUAGE ',INUAR) ENDIF SEGSUP,MLMOTS RETURN c c pas d operande correcte trouve c 6 CONTINUE CALL ERREUR(21) C CALL QUETYP(MOTERR(1:8),0,IRETOU) C IF(IRETOU .NE. 0) THEN C CALL ERREUR (39) C ELSE C CALL ERREUR(533) C ENDIF END