Télécharger prchan.eso

Retour à la liste

prchan
C PRCHAN    SOURCE    SP204843  24/09/27    21:15:16     12017          
 
      SUBROUTINE PRCHAN
 
C--------------------------------------------------------------------
C   Ce sous programme permet :
C
C   - De changer les elements d'un maillage
C
C   - De convertir un MCHAML en CHPOINT (mot cle CHPO)
C
C   - De convertir un CHPOINT en MCHAML (mot cle CHAM)
C
C   - De changer le support d'un MCHAML
C     (mots cles NOEUDS, GRAVITE, RIGIDITE, MASSE et STRESSES)
C
C   - De changer l'attribut d'un champ de points
C
C   - De changer le nom du constituant d'un champ par element ou d un modele
C
C   - De changer une rigidite cree par RELA en rigidite de dependence
C
C   - Changer la casse d'un mot
C--------------------------------------------------------------------
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
 
-INC PPARAM
-INC CCOPTIO
-INC CCNOYAU
-INC CCHAMP
-INC CCGEOME
 
-INC SMELEME
-INC SMLENTI
-INC SMCHPOI
-INC SMCHAML
-INC SMRIGID
-INC SMMODEL
-INC SMLMOTS
-INC SMCOORD
 
      PARAMETER (NTYP=31,LATRI=4,NLIG=9,NMOY=3)
      CHARACTER*8 LISTYP(NTYP)
      CHARACTER*4 LATRIB(LATRI)
      CHARACTER*4 LISMAT(3), LISCOM(2),LISMUL(2)
      CHARACTER*4 MOTLIG(NLIG), MOMOYE(NMOY)
      CHARACTER*72 CHAR,CHAR1
      CHARACTER*8  CHAR8
      CHARACTER*(LONOM) CNOM1,CNOM2
      PARAMETER (LMOTL=512)
      CHARACTER*(LMOTL) MENT,MSOR
      CHARACTER*4 MOT1,MOT2,MOT3,MOT4
 
 
      DATA LISTYP / 'NOEUD   ', 'GRAVITE ', 'RIGIDITE', 'MASSE   ',
     &              'STRESSES', 'THERMIQU', 'FACE    ', 'P1CENTRE',
     &              'MSOMMET ', 'CHPO    ', 'CHAM    ', '--------',
     &              '--------', 'TYPE    ', 'ATTRIBUT', 'CONS    ',
     &              'DEPE    ', 'COND    ', 'COMP    ', 'INCO    ',
     &              'TABL    ', 'MINU    ', 'MAJU    ', 'TITR    ',
     &              'LEGE    ', 'NOMABS  ', 'NOMORD  ', 'STYL    ',
     &              'MARQ    ', 'TAIL    ', 'COUL    '/
 
      DATA LATRIB / 'NATU', 'INDE', 'DIFF', 'DISC' /
 
      DATA LISMAT / 'SYME', 'ANTI', 'QUEL' /
      DATA LISCOM / 'COMP', 'REEL' /
      DATA LISMUL / 'MULT','DUPL' /
 
      DATA MOMOYE / 'SOMM', 'MOYE','SUPP'/
      DATA MOTLIG / 'LIGN', 'LINE', 'QUAD', 'QUAF', 'MACR', 'CUBI',
     &              'DECL', 'LINB', 'SURF' /
 
C     On a besoin du MCOORD plus loin
****  SEGACT,MCOORD
 
      ILIG=0
      CNOM1   = ' '
      CNOM2   = ' '
 
C --- Lecture des mots-clés de LISTYP --> IPLAC
      CALL LIRMOT(LISTYP,NTYP,IPLAC,0)
      IF (IERR.NE.0) RETURN
      IF (IPLAC.NE.0) GOTO 1
 
C
C --- Lecture des mots-clés de MOTLIG --> ILIG
      CALL LIRMOT(MOTLIG,NLIG,ILIG,0)
      IF (ILIG.EQ.1) THEN
         CALL CHANLG
         RETURN
      ELSEIF(ILIG.EQ.2) THEN
         CALL CHANLI
         RETURN
      ELSEIF(ILIG.EQ.3) THEN
         CALL CHANQU
         RETURN
      ELSEIF(ILIG.EQ.4) THEN
         CALL LIROBJ('MAILLAGE',MELEME,1,IRET)
         CALL ACTOBJ('MAILLAGE',MELEME,1)
         IF(IRET.EQ.0)RETURN
         CALL KQCEST(MELEME,IKR)
         CALL ACTOBJ('MAILLAGE',MELEME,1)
         CALL ECROBJ('MAILLAGE',MELEME)
         IF(IKR.EQ.2)THEN
            CALL CHANQU
         ENDIF
         CALL C20227
         RETURN
      ELSEIF(ILIG.EQ.5) THEN
         CALL CMACRO
         RETURN
      ELSEIF(ILIG.EQ.6) THEN
         CALL CCUBIC
         RETURN
      ELSEIF(ILIG.EQ.7) THEN
         CALL CQ2L
         RETURN
      ELSEIF(ILIG.EQ.8) THEN
         CALL CLINB
         RETURN
      ELSEIF(ILIG.EQ.9) THEN
         CALL ENVVO2(1)
         RETURN
      ENDIF
C
C --- Lecture parmi la liste des NOMS --> ITY
      CALL LIRMOT(NOMS,NOMBR,ITY,0)
      IF (ITY.EQ.0) ITY=ILCOUR
      CALL LIROBJ('MAILLAGE',MELEME,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 99
      CALL ACTOBJ('MAILLAGE',MELEME,1)
 
        CALL QUENOM(CNOM1)
C CB    On ajoute la lecture d'un LISTENTIER optionnel pour indiquer
C       quels N-uplet de noeuds du MELEME vont constituer la connectivité
C       du MAILLAGE final
        CALL LIROBJ('LISTENTI',MLENTI,0,IRETOU)
        IF (IRETOU.NE.0) THEN
          SEGACT,MLENTI
          CALL QUENOM(CNOM2)
          ITYP1 = MELEME.ITYPEL
          IF (ITYP1 .NE. 1) THEN
            CALL ERREUR(16)
            RETURN
          ENDIF
          NBEL1 = MELEME.NUM(/2)
          JG = LECT(/1)
C  Cas des ELEMENTS POLY et MULT
          IF (NOMS(ITY).EQ.'POLY' .OR. NOMS(ITY).EQ.'MULT') THEN
            NBNN   = JG
            NBELEM = 1
C  Cas des ELEMENTS classiques
          ELSE
            NBNN   = NBNNE(ITY)
            NBELEM = JG/NBNN
            IF (MOD(JG,NBNN) .NE. 0) THEN
              MOTERR(1:8) =CNOM2
              MOTERR(9:12)=NOMS(ITY)
              CALL ERREUR(1057)
              RETURN
            ENDIF
          ENDIF
 
          NBSOUS=0
          NBREF =0
          SEGINI,IPT1
          IPT1.ITYPEL=ITY
          DO 259 IEL=1,NBELEM
            J=(IEL-1) * NBNN
            IPT1.ICOLOR(IEL)=IDCOUL
            DO 2591 I=1,NBNN
              IELEM = MLENTI.LECT(J+I)
              IF((IELEM .GT. NBEL1) .OR. (IELEM .LE. 0)) THEN
                INTERR(1)  =IELEM
                MOTERR(1:8)=CNOM1
                CALL ERREUR(1058)
                SEGSUP,IPT1
                RETURN
              ENDIF
              IPT1.NUM(I,IEL)=MELEME.NUM(1,IELEM)
 2591       CONTINUE
 259      CONTINUE
          MELEME = IPT1
        ELSE
          CALL CHANGE(MELEME,ITY)
          IF (IERR.NE.0) RETURN
        ENDIF
        CALL ACTOBJ('MAILLAGE',MELEME,1)
        CALL ECROBJ('MAILLAGE',MELEME)
      RETURN
 
C        PAS D OPERANDE CORRECTE TROUVE --> ERREUR
 99   CONTINUE
      CALL QUETYP(MOTERR(1:8),0,IRETOU)
      IF (IRETOU.NE.0) THEN
        CALL ERREUR (39)
      ELSE
        CALL ERREUR(533)
      ENDIF
      RETURN
C
C     OPERANDE CORRECTE TROUVE dans LISTYP : on aiguille
C
   1  CONTINUE
      GOTO (300, 300, 300, 300, 300, 300, 300, 300, 300, 100,
     &      800, 400, 600,1200,1300,1400,1500,1500,1600,1700,
     &     2100,2200,2200,3000,3000,3000,3000,3000,3000,3000,3000),IPLAC
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     CHANGEMENT D'UN MCHAML EN CHPOINT
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
 100  CALL LIRMOT(MOMOYE,NMOY,IMOY,0)
      IF(IMOY.EQ.0) IMOY=2
      IMOY=IMOY-1
c     MOYENNE(par defaut) : IMOY=1   SOMME : IMOY=0  GAUSS:IMOY=2
 
C     Tente la lecture optionnelle d'un CHPOINT
      CALL LIROBJ('CHPOINT ',IPOI2,0,IRETO3)
      IF(IERR.NE.0) RETURN
      IF(IRETO3.EQ.1) THEN
        CALL ACTOBJ('CHPOINT ',IPOI2,1)
C       Tente la lecture optionnelle d'un MMODEL
        CALL LIROBJ('MMODEL  ',IPOI1,0,IRETO1)
        IF(IRETO1 .EQ. 1)CALL ACTOBJ('MMODEL  ',IPOI1,1)
        IF(IERR.NE.0) RETURN
C       L'OBJET fourni etait deja un CHPOINT on crée un CHPOINT dupliqué
        MCHPOI=IPOI2
        SEGINI,MCHPO1=MCHPOI
        SEGACT,MCHPO1*NOMOD
        CALL ACTOBJ('CHPOINT ',MCHPO1,1)
        CALL ECROBJ('CHPOINT ',MCHPO1)
        IF(IERR.NE.0) RETURN
        RETURN
      ENDIF
 
C     Tente la lecture obligatoire d'un MMODEL
      CALL LIROBJ('MMODEL  ',IPOI1,1,IRETO1)
      CALL ACTOBJ('MMODEL  ',IPOI1,1)
      IF(IERR.NE.0) RETURN
 
C     Tente la lecture obligatoire d'un MCHAML
      CALL LIROBJ('MCHAML  ',IPOI2,1,IRETO2)
      CALL ACTOBJ('MCHAML  ',IPOI2,1)
      IF(IERR.NE.0) RETURN
      CALL REDUAF(IPOI2,IPOI1,IPOI3,0,IRET,KERR)
      IF (IRET .EQ. 0) THEN
        CALL ERREUR (KERR)
        IF(IERR .NE. 0) RETURN
      ELSE
        IPOI2 = IPOI3
      ENDIF
 
cbp, 2018-03-26 : option SUPPORT pour sortir un chpoint defini aux points
c                 de Gauss sans changer de support (but : tracer)
      IF(IMOY.EQ.2) THEN
*       Lecture éventuelle d'un CHAMELEM de caractéristiques
        IPCARA=0
        CALL LIROBJ('MCHAML  ',IPCARA,0,IRET)
        IF(IRET.EQ.1) CALL ACTOBJ('MCHAML  ',IPCARA,1)
*       Appel a la SUBROUTINE de travail
        CALL CHAPO(IPOI1,IPOI2,IPCARA,IPOI4,IRET)
        CALL ACTOBJ('CHPOINT',IPOI4,1)
        IF(IERR.EQ.0) CALL ECROBJ('CHPOINT ',IPOI4)
        RETURN
      ENDIF
 
      CALL CHASUP(IPOI1,IPOI2,IPOI3,IRT2,1)
      IF(IRT2.NE.0) THEN
        CALL ERREUR(IRT2)
        RETURN
      ENDIF
      CALL CHAMPO(IPOI3,IMOY,IPOI4,IRET)
C               A PRIORI LE CHPO EST DE NATURE DIFFUSE
      MCHPOI = IPOI4
      SEGACT MCHPOI*MOD
      JATTRI(1) = 1
      CALL ACTOBJ('CHPOINT ',IPOI4,1)
      CALL ECROBJ('CHPOINT ',IPOI4)
      RETURN
 
 400  CONTINUE
 600  CONTINUE
      RETURN
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     CHANGEMENT D'UN CHPOINT EN MCHAML A PARTIR D'UN MODELE
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     Lecture éventuelle d'un lieu support
 800  CALL LIRMOT(LISTYP,9,ISUP,0)
      IF (IERR.NE.0) RETURN
      IPLAC = ISUP
C Par defaut, le support est aux noeuds
      IF (IPLAC.EQ.0) IPLAC = 1
 
C     Tente la lecture optionnelle d'un MCHAML
      CALL LIROBJ('MCHAML  ',IPOI2,0,IRETOU)
      IF(IRETOU.EQ.1) CALL ACTOBJ('MCHAML  ',IPOI2,1)
      IF (IERR.NE.0) RETURN
      IF (IRETOU.NE.0) THEN
        CALL REFUS
        GOTO 300
      ENDIF
 
      CALL LIROBJ('MMODEL  ',IPOI1,0,IRETOU)
      IF (IERR.NE.0) RETURN
      IF (IRETOU.EQ.0) GOTO 900
      CALL ACTOBJ('MMODEL  ',IPOI1,1)
 
      CALL LIROBJ('CHPOINT ',IPOI2,1,IRETOU)
      CALL ACTOBJ('CHPOINT ',IPOI2,1)
      IF(IERR.NE.0) RETURN
 
      LONS=0
      MMODEL=IPOI1
      N1=KMODEL(/1)
      DO 41 L=1,N1
        IMODEL=KMODEL(L)
        IF (FORMOD(1).EQ.'NAVIER_STOKES') LONS=LONS+1
 41   CONTINUE
 
      IF(LONS.EQ.0) THEN
C
C     Tente la lecture optionnelle du Sous_Type
        CALL LIRCHA(CHAR,0,IRETOU)
        IF (IERR.NE.0) RETURN
        IF (IRETOU.EQ.0) THEN
          CHAR=' '
          IRETOU=1
        ENDIF
 
        CALL CHAME1(0,IPOI1,IPOI2,CHAR(1:IRETOU),IPOI3,IPLAC)
        IF (IERR.NE.0) RETURN
 
      ELSEIF(LONS.EQ.N1) THEN
C       Traitement specifique dans le cas d'un objet modele de
C       type Navier-Stokes
        CALL KCHAM1(IPOI1,IPOI2,IPOI3)
        IF (IERR.NE.0) RETURN
        IF (ISUP.NE.0) THEN
          CALL CHASPG(IPOI1,IPOI3,IPOI4,IRET,ISUP)
          IF (IRET.NE.0) CALL ERREUR(IRET)
          IF (IERR.NE.0) RETURN
          IPOI3=IPOI4
        ENDIF
      ENDIF
      CALL ACTOBJ('MCHAML  ',IPOI3,1)
      CALL ECROBJ('MCHAML  ',IPOI3)
      RETURN
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     CHANGEMENT DE CHPOINT EN MCHAML A PARTIR D'UN MAILLAGE
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     Tente la lecture obligatoire d'un MAILLAGE
 900  CALL LIROBJ('MAILLAGE',IPOI1,1,IRETO1)
      CALL ACTOBJ('MAILLAGE',IPOI1,1)
      IF(IERR.NE.0) RETURN
 
C     Tente la lecture obligatoire d'un CHPOINT
      CALL LIROBJ('CHPOINT ',IPOI2,1,IRETO2)
      CALL ACTOBJ('CHPOINT ',IPOI2,1)
      IF(IERR.NE.0) RETURN
 
C     Tente la lecture optionnelle du Sous_Type
      CALL LIRCHA(CHAR,0,IRETOU)
      IF(IERR.NE.0) RETURN
C
      IF (IRETOU.EQ.0) THEN
        CHAR  ='SCALAIRE'
        IRETOU=8
      ENDIF
C
      CALL CHAME1(IPOI1,0,IPOI2,CHAR(1:IRETOU),IPOI3,1)
      IF(IERR.NE.0) RETURN
      CALL ACTOBJ('MCHAML  ',IPOI3,1)
      CALL ECROBJ('MCHAML  ',IPOI3)
      RETURN
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     CHANGEMENT DE SUPPORT D'UN MCHAML
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
 300  CALL LIROBJ('MCHAML  ',IPOI2,1,IRETOU)
      CALL ACTOBJ('MCHAML  ',IPOI2,1)
      IF (IERR.NE.0) RETURN
 
      CALL LIROBJ('MMODEL  ',IPOI1,1,IRETOU)
      CALL ACTOBJ('MMODEL  ',IPOI1,1)
      IF(IERR.NE.0) RETURN
 
      LONS=0
      MMODEL=IPOI1
      N1=KMODEL(/1)
      DO 42 L=1,N1
        IMODEL=KMODEL(L)
        IF(FORMOD(1).EQ.'NAVIER_STOKES') LONS=LONS+1
 42   CONTINUE
 
      MCHELM =IPOI2
 
      IF(LONS.EQ.0) THEN
C       cas normal
C       On procède au REDUAF
        CALL REDUAF(IPOI2,IPOI1,IPOI3,0,IRET,KERR)
        IF (IRET .EQ. 0) THEN
          CALL ERREUR (KERR)
          IF (IERR .NE. 0) RETURN
        ENDIF
        IPOI2 = IPOI3
 
        CALL CHASUP(IPOI1,IPOI2,IPOI3,IRT2,IPLAC)
        IF(IRT2.NE.0) THEN
          CALL ERREUR(IRT2)
          RETURN
        ENDIF
      ELSEIF(LONS.EQ.N1) THEN
C       Traitement specifique dans le cas d'un objet modele de
C       type Navier-Stokes
        CALL CHASPG(IPOI1,IPOI2,IPOI3,IRT2,IPLAC)
        IF (IRT2.NE.0) CALL ERREUR(IRT2)
        IF (IERR.NE.0) RETURN
      ENDIF
 
C     Tente la lecture optionnelle du Sous_Type
      CALL LIRCHA(CHAR,0,IRETOU)
      IF(IERR.NE.0) RETURN
      IF (IRETOU .NE.0) THEN
        IPOI1=IPOI3
        GOTO 1201
 
      ELSE
C       On remet le TITCHE du champ d'entree
        SEGACT MCHELM
        L1=TITCHE(/1)
 
        MCHEL1 = IPOI3
        SEGACT MCHEL1*MOD
        N1=MCHEL1.INFCHE(/1)
        N3=MCHEL1.INFCHE(/2)
        SEGADJ,MCHEL1
        MCHEL1.TITCHE=MCHELM.TITCHE
      ENDIF
C
      CALL ACTOBJ('MCHAML  ',IPOI3,1)
      CALL ECROBJ('MCHAML  ',IPOI3)
      RETURN
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     CHANGEMENT DE TITRE (mot clé 'TYPE') D'UN MCHAML
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
1200  CALL LIROBJ('MCHAML  ',IPOI1,0,IRETOU)
c     mot clé 'TYPE' aussi utilisé pour RIGIDITE
      IF(IRETOU.EQ.0) GOTO 1250
      CALL ACTOBJ('MCHAML  ',IPOI1,1)
      CALL LIRCHA(CHAR,1,IRETOU)
      IF(IERR.NE.0) RETURN
 
1201  CALL CHATIT(IPOI1,CHAR(1:IRETOU),IPOI2)
      CALL ACTOBJ('MCHAML  ',IPOI2,1)
      CALL ECROBJ('MCHAML  ',IPOI2)
      RETURN
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     CHANGEMENT DU TYPE D'UNE RIGIDITE
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
1250  CALL LIROBJ('RIGIDITE',IRIG,1,IRETOU)
      IF (IERR.NE.0) RETURN
      RI1 = IRIG
      SEGINI,MRIGID=RI1
      CALL LIRCHA(CHAR8,1,IRETOU)
      IF(IERR.NE.0) RETURN
      MTYMAT = CHAR8
      SEGDES,MRIGID
      CALL ECROBJ('RIGIDITE',MRIGID)
      RETURN
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     CHANGEMENT DE L'ATTRIBUT D'UN CHAMP DE POINTS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
1300  CONTINUE
C
      CALL LIRMOT(LATRIB,LATRI,IPLAC,1)
      IF (IERR.NE.0) RETURN
      CALL LIROBJ('CHPOINT ',IPOI1,1,IRETOU)
      CALL ACTOBJ('CHPOINT ',IPOI1,1)
      IF (IERR.NE.0) RETURN
      MCHPOI = IPOI1
C               CHANGEMENT DE NATURE
      IF ( IPLAC .EQ. 1 ) THEN
        CALL LIRMOT(LATRIB,LATRI,IPLAC,1)
        IPLAC = IPLAC - 2
        SEGINI, MCHPO1=MCHPOI
        DO iou=1,mchpo1.ipchp(/1)
          msoupo=mchpo1.ipchp(iou)
          segini,msoup1=msoupo
          mchpo1.ipchp(iou)=msoup1
        ENDDO
        IPOI2 = MCHPO1
        MCHPO1.JATTRI(1) = IPLAC
        CALL ACTOBJ('CHPOINT ',IPOI2,1)
        CALL ECROBJ('CHPOINT ',IPOI2)
      ELSE
         MOTERR(1:4)='NATU'
         CALL ERREUR(396)
         RETURN
      ENDIF
      RETURN
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     CHANGEMENT DE CONSTITUANT D'UN MCHAML ou d'un MMODEL
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
1400  CALL LIROBJ('MCHAML  ',IPOI1,0,IRETOU)
      IF (IERR.NE.0) RETURN
      IF (iretou.eq.1) THEN
        CALL ACTOBJ('MCHAML  ',IPOI1,1)
        MCHELM = IPOI1
        SEGINI , MCHEL1 = MCHELM
        CALL LIRCHA(CHAR,1,LCHAR)
        IF (IERR.NE.0) RETURN
        N1 = MCHEL1.CONCHE(/2)
        CHAR1 = MCHEL1.CONCHE(1)
        DO 1410 I=1,N1
          IF ( MCHEL1.CONCHE(I) .NE. CHAR1) THEN
            CALL ERREUR(716)
            SEGSUP MCHEL1
            RETURN
          ENDIF
1410    CONTINUE
 
        DO 1420 I=1,N1
          MCHEL1.CONCHE(I) = CHAR
1420    CONTINUE
        IPOI1 = MCHEL1
        CALL ACTOBJ('MCHAML  ',IPOI1,1)
        CALL ECROBJ('MCHAML  ',IPOI1)
        RETURN
 
      ELSE
        CALL LIROBJ('MMODEL  ',IPOI1,1,IRETOU)
        CALL ACTOBJ('MMODEL  ',IPOI1,1)
        IF (ierr.ne.0) RETURN
        mmode1 = ipoi1
        n1 = mmode1.kmodel(/1)
        imode1 = mmode1.kmodel(1)
        char1(1:LCONMO) = imode1.conmod
        IF (n1.gt.1) THEN
          DO ikmo = 2,n1
            imode2 = mmode1.kmodel(ikmo)
             IF (char1(1:LCONMO).ne.imode2.conmod(1:LCONMO)) THEN
               CALL erreur(732)
               RETURN
             ENDIF
          ENDDO
        ENDIF
        segini,mmodel = mmode1
      CALL LIRCHA(CHAR,1,LCHAR)
      IF (IERR.NE.0) RETURN
        DO ikmo = 1,n1
          imode1 = kmodel(ikmo)
          segini,imodel = imode1
            NFOR=FORMOD(/2)
C   CAS DARCY OU NAVIER ON OUBLIE LA TABLE DE PRECONDITIONNEMENT
            CALL PLACE (FORMOD,NFOR,IDARC,'DARCY')
            CALL PLACE (FORMOD,NFOR,IEULE,'EULER')
            CALL PLACE (FORMOD,NFOR,INAVI,'NAVIER_STOKES')
            IF((IDARC.NE.0).OR.(INAVI.NE.0).OR.(IEULE.NE.0)) INFMOD(2)=0
          kmodel(ikmo) = imodel
          conmod = char
        ENDDO
        ipoi1 = mmodel
        CALL ACTOBJ('MMODEL  ',IPOI1,1)
        CALL ECROBJ('MMODEL  ',ipoi1)
        RETURN
      ENDIF
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     CHANGEMENT D UNE RIGIDITE CREE PAR RELATION
C     EN MATRICE DE DEPENDANCE OU DE CONDENSATION
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
1500  CALL LIROBJ('RIGIDITE',IRIG,1,iret)
      IF (IERR.NE.0) RETURN
 
C   verification que la rigidité ne contient que des relation
C   c'est à dire n'est supportée que par des maillage de type 22
C
      MRIGID = IRIG
      SEGACT, MRIGID*NOMOD
      DO 1510 I=1,IRIGEL(/2)
        MELEME = IRIGEL(1,I)
        SEGACT , MELEME*NOMOD
        IF (ITYPEL.NE.22) THEN
            CALL ERREUR(889)
            RETURN
        ENDIF
1510   CONTINUE
C
C     matrice de depedence
      MRIGID = IRIG
      SEGACT MRIGID
      segini , ri1=MRIGID
      iri1 = ri1
C      nrige=8
      nrigel=irigel(/2)
      segadj ri1
      DO 1520 i=1,nrigel
      ri1.irigel(8,i)=1
1520  CONTINUE
      segdes mrigid,ri1
C
        IF(iplac.eq.17) THEN
      CALL ECROBJ('RIGIDITE',iri1)
        ELSE
      CALL depen3(iri1,iri2)
      CALL dual00(iri2,iri3)
      CALL ECROBJ('RIGIDITE',iri3)
      CALL ECROBJ('RIGIDITE',iri2)
        ENDIF
      RETURN
c
 1600 CALL nomc
      RETURN
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     CHANGEMENT DE NOM D'INCONNUES PRIMALE ET DUALE D'UNE MATRICE
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
 1700 CONTINUE
      CALL LIROBJ('MATRIK  ',IPO1,0,IRETOU)
      IF (IRETOU.NE.0) THEN
         CALL REFUS
         CALL MACHIN
         RETURN
      ENDIF
C     lecture du mot cle COMPLEXE ou REEL ou rien
      CALL LIRMOT(LISCOM,2,ival,0)
      CALL LIROBJ('RIGIDITE',RI1,1,iretou)
      IF( ierr.ne.0) RETURN
      IF(IIMPI.ge.3) write(IOIMP,*) '>>> CHAN INCO de ',RI1,' <<<'
 
c  ---Cas de 4 LISTMOTS ou 4 MOT ---
      IF(IVAL.EQ.0 )THEN
         CALL LIROBJ('LISTMOTS',mlmot1,0,ilmots)
         IF (ilmots.eq.0) then
            CALL LIRCHA(MOT1,1,iretou)
            IF( ierr.ne.0) RETURN
            CALL LIRCHA(MOT2,1,iretou)
            IF( ierr.ne.0) RETURN
            CALL LIRCHA(MOT3,1,iretou)
            IF( ierr.ne.0) RETURN
            CALL LIRCHA(MOT4,1,iretou)
            IF( ierr.ne.0) RETURN
            JGN=4
            JGM=1
            segini mlmot1,mlmot2,mlmot3,mlmot4
            mlmot1.mots(1)=mot1
            mlmot2.mots(1)=mot2
            mlmot3.mots(1)=mot3
            mlmot4.mots(1)=mot4
         ELSE
            CALL LIROBJ('LISTMOTS',mlmot2,1,iretou)
            IF( ierr.ne.0) RETURN
            CALL LIROBJ('LISTMOTS',mlmot3,1,iretou)
            IF( ierr.ne.0) RETURN
            CALL LIROBJ('LISTMOTS',mlmot4,1,iretou)
            IF( ierr.ne.0) RETURN
         ENDIF
C       lecture de la nature SYME ANTI ...
        IPLAMA=0
        CALL LIRMOT(LISMAT,3,IPLAMA,0)
C       Par defaut : 'NON SYMETRIQUE'
        IF (IPLAMA.EQ.0) IPLAMA=3
 
C       lecture du mot cle MULT ou DUPL (ou rien)
        CALL LIRMOT(LISMUL,2,IPLMUL,0)
C
        segact mlmot1,mlmot2,mlmot3,mlmot4
        il1=mlmot1.mots(/2)
        il2=mlmot2.mots(/2)
        il3=mlmot3.mots(/2)
        il4=mlmot4.mots(/2)
        IF(il1.ne.il2.or.il3.ne.il4) THEN
*dbg           write(ioimp,*) 'il1,il2,il3,il4=',il1,il2,il3,il4
           CALL erreur(854)
           RETURN
        ENDIF
        IF(IIMPI.ge.3) write(IOIMP,*)
     $       'cas de 4 LISTMOTS ou 4 MOTS fournis '
 
c  ---Cas COMPLEXE/REEL---
      ELSE
        JGN=4
        JGM=lnomdd
        segini mlmot1,mlmot2,mlmot3,mlmot4
        DO jkl=1,lnomdd
        mlmot1.mots(jkl)=nomdd(jkl)
        mlmot2.mots(jkl)(1:1)='I'
        mlmot2.mots(jkl)(2:4)=nomdd(jkl)(1:3)
        mlmot3.mots(jkl)=nomdu(jkl)
        mlmot4.mots(jkl)(1:1)='I'
        mlmot4.mots(jkl)(2:4)=nomdu(jkl)(1:3)
        ENDDO
        IF(IIMPI.ge.3) write(IOIMP,*) 'cas COMPLEXE/REEL'
      ENDIF
 
C     Creation du MRIGID de sortie = presque copie de l entree
      segini,mrigid=ri1
      ichole=0
      imgeo1=0
      imgeo2=0
      isupeq=0
      jrcond=0
      jrdepp=0
      jrdepd=0
      jrelim=0
      jrgard=0
      jrtot=0
      DO 1701  k=1,irigel(/2)
         irigel(7,k) = IPLAMA-1
C        creation des XMATRI (avec la symetrie identique a MRIGID.irigel(4,k))
         XMATR1=irigel(4,k)
         segini,XMATRI=XMATR1
         irigel(4,k)=XMATRI
         XMATRI.SYMRE=irigel(7,k)
         XMATRI.SYMVER=0
c        creation et modif du DESCR
         des1=irigel(3,k)
         segini,descr=des1
         irigel(3,k)=descr
         nbinc=lisinc(/2)
         nbdua=lisdua(/2)
         DO 1702  ka=1,nbinc
            IF(lisinc(ka).EQ.'LX  '.and.iplmul.eq.0) go to 1702
            DO 1703 kb=1,il1
               IF( lisinc(ka).eq.mlmot1.mots(kb) ) THEN
                  lisinc(ka)=mlmot2.mots(kb)
                  go to 1702
               ENDIF
 1703       CONTINUE
 1702    CONTINUE
         DO 1704  ka=1,nbdua
            IF( lisdua(ka).eq.'FLX '.and.iplmul.eq.0) go to 1704
            DO 1705 kb=1,il3
               IF( lisdua(ka).eq.mlmot3.mots(kb) ) THEN
                  lisdua(ka)=mlmot4.mots(kb)
                  go to 1704
               ENDIF
 1705       CONTINUE
 1704    CONTINUE
 
C     on teste si c'est un LX : si oui, on crée un nouveau noeud
C     rem : on suppose qu'il n y a qu'1 LX par matrice et a une
C           position quelconque
         IF(iplmul.lt.2) goto 1706
         DO 1707 ka=1,min(nbinc,nbdua)
            IF (lisinc(ka).eq.'LX  '.and.lisdua(ka).eq.'FLX ') THEN
               IF(IIMPI.ge.3) write(IOIMP,*)
     $              'creation de nouveaux noeuds LX'
c           IF(IIMPI.ge.3) THEN
c             write(IOIMP,*) 'mlmot1=',(mlmot1.mots(iou),iou=1,il1)
c             write(IOIMP,*) 'mlmot2=',(mlmot2.mots(iou),iou=1,il2)
c             write(IOIMP,*) 'mlmot3=',(mlmot3.mots(iou),iou=1,il3)
c             write(IOIMP,*) 'mlmot4=',(mlmot4.mots(iou),iou=1,il4)
c             write(IOIMP,*) 'lisinc=',(lisinc(iou),iou=1,nbinc)
c             write(IOIMP,*) 'lisdua=',(lisdua(iou),iou=1,nbdua)
c           ENDIF
               ipt1=irigel(1,k)
               segini,meleme=ipt1
               irigel(1,k)=meleme
               segact,MCOORD*MOD
               inp=NOELEP(ka)
               DO 1708 iel=1,num(/2)
                  NBPTS=NBPTS + 1
                  num(inp,iel)=NBPTS
 1708          CONTINUE
               segadj,MCOORD
               segdes,mcoord
            ENDIF
 1707    CONTINUE
 1706    CONTINUE
 1701 CONTINUE
      IF(ival.eq.0) THEN
         if (ilmots.eq.0) then
            segsup mlmot1,mlmot2,mlmot3,mlmot4
         endif
      ELSE
         segsup mlmot1,mlmot2,mlmot3,mlmot4
      ENDIF
      CALL ACTOBJ('RIGIDITE',mrigid,1)
      CALL ECROBJ('RIGIDITE',mrigid)
      RETURN
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C changement de presentation d'un chargement
C mise sous forme table de chpoint (plus rapide pour l'opérateur TIRE)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
 2100 CALL chatab
      RETURN
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Changement de la casse d'un mot
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
 2200 CONTINUE
      ICASS=IPLAC-22
      CALL LIRCHA(MENT,1,LENT)
      IF (IERR.NE.0) RETURN
      CALL CHCASS(MENT(1:LENT),ICASS,MSOR(1:LENT))
      CALL ECRCHA(MSOR(1:LENT))
      RETURN
 
 3000 CONTINUE
      CALL QUETYP(CHAR8,1,IRET)
      IF (CHAR8.NE.'CHPOINT'.AND.CHAR8.NE.'EVOLUTIO') THEN
          MOTERR(1:16)='CHPOINT EVOLUTIO'
          CALL ERREUR(471)
          RETURN
      ENDIF
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     Changement de titre d'un CHPOINT
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      IF (CHAR8.EQ.'CHPOINT ') THEN
        CALL LIROBJ('CHPOINT ',IP1,1,IRETOU)
        CALL ACTOBJ('CHPOINT ',IP1,1)
        IF (IERR.NE.0) RETURN
        CALL LIRCHA(CHAR1,1,IRETOU)
        MCHPO1=IP1
        SEGINI,MCHPOI=MCHPO1
        MOCHDE=CHAR1
        CALL ACTOBJ('CHPOINT ',MCHPOI,1)
        CALL ECROBJ('CHPOINT ',MCHPOI)
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     Changement des noms d'une evolution
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      ELSEIF (CHAR8.EQ.'EVOLUTIO') THEN
        CALL LIROBJ('EVOLUTIO',IEV1,1,IRETOU)
        IF (IERR.NE.0) RETURN
        CALL ACTOBJ('EVOLUTIO',IEV1,1)
 
        IFOIS = 0
 4000   CONTINUE
        ITIT1=IPLAC-23
        IENT1=0
        K=0
        char1 = '    '
        IF (ITIT1.LT.5) THEN
          CALL LIRCHA(CHAR1,1,IRETOU)
          IF (IERR.NE.0) RETURN
          CALL PLACE(LISTYP,NTYP,IPLAC,CHAR1)
          IF (IPLAC.NE.0) THEN
            MOTERR(1:4) = LISTYP(ITIT1+23)
            CALL ERREUR(166)
            RETURN
          ENDIF
        ELSE IF (ITIT1.EQ.5) THEN
          CALL LIRCHA(CHAR1,0,IRETOU)
          CALL PLACE(LISTYP,NTYP,IPLAC,CHAR1)
          IF (IPLAC.NE.0) THEN
            CALL REFUS
            IRETOU = 0
          ENDIF
          IF (IRETOU.EQ.0) THEN
            CALL LIRENT(IENT1,1,IRETOU)
            IF (IERR.NE.0) RETURN
            IF (IENT1.EQ.0) IENT1 = -1
          ENDIF
        ELSE IF (ITIT1.EQ.6) THEN
          CALL LIRCHA(CHAR1,0,IRETOU)
          CALL PLACE(LISTYP,NTYP,IPLAC,CHAR1)
          IF (IPLAC.NE.0) THEN
            CALL REFUS
            IRETOU = 0
          ENDIF
          IF (IRETOU.EQ.0) THEN
            CALL LIRENT(IENT1,1,IRETOU)
            IF (IERR.NE.0) RETURN
            IF (IENT1.EQ.0) IENT1 = -1
          ENDIF
        ELSE IF (ITIT1.EQ.7) THEN
          CALL LIRCHA(CHAR1,0,IRETOU)
          CALL PLACE(LISTYP,NTYP,IPLAC,CHAR1)
          IF (IPLAC.NE.0) THEN
            CALL REFUS
            IRETOU = 0
          ENDIF
          IF (IRETOU.EQ.0) THEN
            CALL LIRENT(IENT1,1,IRETOU)
            IF (IERR.NE.0) RETURN
            IF (IENT1.EQ.0) IENT1 = -1
          ENDIF
        ELSE IF (ITIT1.EQ.8) THEN
          CALL LIRCHA(CHAR1,0,IRETOU)
          CALL PLACE(LISTYP,NTYP,IPLAC,CHAR1)
          IF (IPLAC.NE.0) THEN
            CALL REFUS
            IRETOU = 0
          ENDIF
          IF (IRETOU.EQ.0) THEN
            CALL LIRENT(IENT1,1,IRETOU)
            IF (IERR.NE.0) RETURN
            IF (IENT1.EQ.0) IENT1 = -1
          ENDIF
        ENDIF
        IF (CHAR1.NE.'    '.OR.IENT1.NE.0) CALL LIRENT(K,0,IRETOU)
 
C     write(6,*) 'prchan:itit1,ient1,K,char1=',itit1,ient1,K,char1
 
        CALL CHEVOL(IEV1,ITIT1,K,CHAR1,IENT1,IEV2)
        CALL ACTOBJ('EVOLUTIO',IEV2,1)
 
        CALL LIRMOT(LISTYP,NTYP,IPLAC,0)
        IF (IPLAC.GT.23) THEN
          IEV1 = IEV2
          IFOIS = IFOIS+1
          GOTO 4000
        ENDIF
 
        CALL ECROBJ('EVOLUTIO',IEV2)
      ENDIF
 
      END
 
 
 
 
 

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