Télécharger redu.eso

Retour à la liste

redu
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
 
 
 
 
 
 
 
 

© Cast3M 2003 - Tous droits réservés.
Mentions légales