C PRCHAN    SOURCE    GOUNAND   14/01/31    21:15:10     7925           

      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 CCOPTIO
-INC CCHAMP
-INC CCGEOME

-INC SMELEME
-INC SMCHPOI
-INC SMCHAML
-INC SMRIGID
-INC SMMODEL
-INC SMLMOTS
C
      PARAMETER (NTYP=23 , LATRI = 4, NLIG = 8 )
      CHARACTER*8 LISTYP(NTYP)
      CHARACTER*4 LISTATRI(LATRI)
      CHARACTER*4 LISMAT(3), LIRIG(1), liscom(2),lismul(1)
      CHARACTER*4 MOTLIG(NLIG), MOMOYE(2)
      CHARACTER*72  CHAR,CHAR1
      PARAMETER (LMOTL=512)
      CHARACTER*(LMOTL) MENT,MSOR

      DATA LISTYP / 'NOEUD   ', 'GRAVITE ', 'RIGIDITE', 'MASSE   ',
     &              'STRESSES', 'THERMIQU', 'FACE    ', 'P1CENTRE',
     &              'MSOMMET ', 'CHPO    ', 'CHAM    ', '--------',
     &              '--------', 'TYPE    ', 'ATTRIBUT', 'CONS    ',
     &              'DEPE    ', 'COND    ', 'COMP    ', 'INCO    ',
     &              'TABL    ', 'MINU    ', 'MAJU    '/

      DATA LISTATRI / 'NATU', 'INDE', 'DIFF', 'DISC' /

      DATA LISMAT / 'SYME', 'ANTI', 'QUEL' /
      DATA LIRIG  / 'LX  ' /
      DATA LISCOM / 'COMP', 'REEL' /
      DATA LISMUL / 'MULT' /

      DATA MOMOYE/'SOMM','MOYE'/
      DATA MOTLIG / 'LIGN', 'LINE', 'QUAD', 'QUAF', 'MACR', 'CUBI',
     &              'DECL', 'LINB' /

      ILIG=0

      CALL LIRMOT(LISTYP,NTYP,IPLAC,0)
*      WRITE(IOIMP,*) 'IPLAC=',IPLAC
      IF (IERR.NE.0) RETURN
C
      IF (IPLAC.EQ.0) 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)
        IF(IRET.EQ.0)RETURN
        CALL KQCEST(MELEME,IKR)
        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
      ENDIF
C
      IF (IPLAC.EQ.0) THEN
        CALL LIRMOT(NOMS,NOMBR,ITY,0)
        IF (ITY.EQ.0) ITY=ILCOUR
        CALL LIROBJ('MAILLAGE',MELEME,0,IRETOU)
        IF (IRETOU.EQ.1) THEN
           SEGACT MELEME
           CALL CHANGE(MELEME,ITY)
           IF(IERR.EQ.0) CALL ECROBJ('MAILLAGE',MELEME)
           SEGDES MELEME
           RETURN
        ELSE
C
C    PAS D OPERANDE CORRECTE TROUVE
C
           CALL QUETYP(MOTERR(1:8),0,IRETOU)
           IF(IRETOU.NE.0) THEN
              CALL ERREUR (39)
           ELSE
              CALL ERREUR(533)
           ENDIF
           RETURN
        ENDIF
C
C       OPERANDE CORRECTE TROUVE
C
      ELSE
      GO TO ( 300, 300, 300, 300, 300, 300, 300, 300, 300, 100,
     &        800, 400, 600,1200,1300,1400,1500,1500,1600,1700,
     &       2100,2200,2200),IPLAC
C
C     CHANGEMENT EN CHPOINT D'UN MCHAML
C
 100  CALL LIRMOT(MOMOYE,2,IMOY,0)
      IF(IMOY.EQ.0) IMOY=2
      IMOY=IMOY-1
      CALL LIROBJ('MCHAML  ',IPOI2,1,IRETOU)
      IF(IERR.NE.0) RETURN
      CALL LIROBJ('MMODEL',IPOI1,1,IRETOU)
      IF(IERR.NE.0) RETURN
      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
      SEGDES MCHPOI
      CALL ECROBJ('CHPOINT ',IPOI4)
      RETURN
C
 200  CONTINUE
 400  CONTINUE
 600  CONTINUE
      RETURN
C
C     CHANGEMENT DE CHPOINT EN MCHAML A PARTIR D'UN MODELE
C
 800  CALL LIROBJ('MMODEL  ',IPOI1,0,IRETOU)
      IF(IERR.NE.0) RETURN
      IF(IRETOU.EQ.0) GOTO 900
      CALL LIROBJ('CHPOINT ',IPOI2,1,IRETOU)
      IF(IERR.NE.0) RETURN

      LONS=0
      MMODEL=IPOI1
      SEGACT MMODEL
        N1=KMODEL(/1)
        DO 41 L=1,N1
        IMODEL=KMODEL(L)
        SEGACT IMODEL
         IF(FORMOD(1).EQ.'NAVIER_STOKES') LONS=LONS+1
        SEGDES IMODEL
 41     CONTINUE
      SEGDES MMODEL

      IF(LONS.EQ.0) THEN
*
*     LECTURE DU LIEU SUPPORT DU MCHAML
*
      CALL LIRMOT(LISTYP,5,ISUP ,0)
      IF (IERR.NE.0) RETURN
      IF (ISUP.EQ.0) ISUP=1
*
      CALL LIRCHA(CHAR,0,IRETOU)
      IF(IERR.NE.0) RETURN
C
      IF (IRETOU.EQ.0) THEN
        CHAR=' '
        IRETOU=1
      ENDIF
C
      CALL CHAME1(0,IPOI1,IPOI2,CHAR(1:IRETOU),IPOI3,ISUP)
      IF(IERR.NE.0) RETURN
      CALL ECROBJ('MCHAML  ',IPOI3)
      RETURN

      ELSEIF(LONS.EQ.N1) THEN
C     Traitement specifique dans le cas d'un objet modele de
C     type Navier-Stokes
*
*     LECTURE EVENTUELLE DU SUPPORT CIBLE DU MCHAML
*
      CALL LIRMOT(LISTYP,9,ISUP ,0)
      IF (IERR.NE.0) RETURN
C     ISUP=0 : Transformation CHPO->CHAML en gardant le meme spg
      CALL KCHAM1(IPOI1,IPOI2,IPOI3)
      IF(IERR.NE.0) RETURN
      IF (ISUP.NE.0) THEN
        CALL CHASPG(IPOI1,IPOI3,IPOI4,IRET,ISUP)
C        IF (IRET.NE.0) MCHAM=MCHA1
        IF (IRET.NE.0) CALL ERREUR(IRET)
        IF(IERR.NE.0) RETURN
        IPOI3=IPOI4
      ENDIF
      CALL ECROBJ('MCHAML  ',IPOI3)
      RETURN
      ENDIF
C
C     CHANGEMENT DE CHPOINT EN MCHAML A PARTIR D'UN MAILLAGE
C
 900  CALL LIROBJ('MAILLAGE',IPOI1,1,IRETOU)
      IF(IERR.NE.0) RETURN
      CALL LIROBJ('CHPOINT ',IPOI2,1,IRETOU)
      IF(IERR.NE.0) RETURN
      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 ECROBJ('MCHAML  ',IPOI3)
      RETURN
C
C     CHANGEMENT DE SUPPORT D'UN MCHAML
C
 300  CALL LIROBJ('MMODEL',IPOI1,1,IRETOU)
      IF(IERR.NE.0) RETURN
      CALL LIROBJ('MCHAML',IPOI2,1,IRETOU)
      IF(IERR.NE.0) RETURN

      LONS=0
      MMODEL=IPOI1
      SEGACT MMODEL
        N1=KMODEL(/1)
        DO 42 L=1,N1
        IMODEL=KMODEL(L)
        SEGACT IMODEL
         IF(FORMOD(1).EQ.'NAVIER_STOKES') LONS=LONS+1
        SEGDES IMODEL
 42     CONTINUE
      SEGDES MMODEL

      IF(LONS.EQ.0) THEN
C     cas normal
      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
      CALL ECROBJ('MCHAML',IPOI3)
      RETURN
C
C     CHANGEMENT DE TITRE D'UN MCHAML
C
1200  CALL LIROBJ('MCHAML',IPOI1,1,IRETOU)
      IF(IERR.NE.0) RETURN
      CALL LIRCHA(CHAR,1,IRETOU)
      IF(IERR.NE.0) RETURN
      CALL CHATIT(IPOI1,CHAR(1:IRETOU),IPOI2)
      CALL ECROBJ('MCHAML',IPOI2)
      ENDIF
      RETURN
C
C       CHANGEMENT DE L'ATTRIBUT D'UN CHAMP DE POINTS
C
1300  CONTINUE
C
      CALL LIRMOT(LISTATRI,LATRI,IPLAC,1)
      IF (IERR.NE.0) RETURN
      CALL LIROBJ('CHPOINT ',IPOI1,1,IRETOU)
      IF (IERR.NE.0) RETURN
      MCHPOI = IPOI1
C               CHANGEMENT DE NATURE
      IF ( IPLAC .EQ. 1 ) THEN
        CALL LIRMOT(LISTATRI,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
        segdes msoup1
        enddo
        IPOI2 = MCHPO1
        MCHPO1.JATTRI(1) = IPLAC
        SEGDES, MCHPOI,MCHPO1
        CALL ECROBJ('CHPOINT ',IPOI2)
      ELSE
         MOTERR(1:4)='NATU'
         CALL ERREUR(396)
         RETURN
      ENDIF
      RETURN
C
C       CHANGEMENT DE CONSTITUANT D'UN CHAMP PAR ELEMENT ou d 'un modele
C
1400  CALL LIROBJ('MCHAML',IPOI1,0,IRETOU)
      IF (IERR.NE.0) RETURN
      if (iretou.ne.0) then
      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
C
      DO 1420 I=1,N1
         MCHEL1.CONCHE(I) = CHAR
1420  CONTINUE
      SEGDES MCHEL1
      IPOI1 = MCHEL1
      CALL ECROBJ('MCHAML',IPOI1)
      RETURN
*
      else
        CALL LIROBJ('MMODEL  ',IPOI1,0,IRETOU)
        if (ierr.ne.0) return
        if (iretou.eq.0) then
           moterr(1:8) = 'MCHAML  '
           moterr(9:16)= 'MMODEL  '
           call erreur(471)
           return
        endif
        mmode1 = ipoi1
        segact mmode1
        n1 = mmode1.kmodel(/1)
        imode1 = mmode1.kmodel(1)
        segact imode1
        char1(1:LCONMO) = imode1.conmod
        segdes imode1
        if (n1.gt.1) then
          do ikmo = 2,n1
            imode2 = mmode1.kmodel(ikmo)
            segact imode2
             if (char1(1:LCONMO).ne.imode2.conmod(1:LCONMO)) then
               segdes imode2
               call erreur(732)
               return
             endif
            segdes imode2
          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
          segdes imodel
        enddo
        segdes mmodel
        ipoi1 = mmodel
        call ecrobj('MMODEL  ',ipoi1)
        return
      endif
C
C        changement  d une rigidite cree par relation
C        en matrice de dependence ou de condensation
C
1500  CALL LIROBJ('RIGIDITE',IRIG,1,iret)
      IF (IERR.NE.0) RETURN

*   verification que la rigidité ne contient que des relation
*   c'est à dire n'est supportée que par des maillage de type 22
*
      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)
            SEGDES MELEME
            SEGDES MRIGID
            RETURN
        ENDIF
       segdes meleme
1510   CONTINUE
C
C                 matrice de depedence
      MRIGID = IRIG
      SEGACT MRIGID
      segini , ri1=MRIGID
      iri1 = ri1
*      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
*  changement de nom d'inconnues primale et duale d'une matrice
 1700 continue
      CALL LIROBJ('MATRIK  ',IPO1,0,IRETOU)
      IF (IRETOU.NE.0) THEN
         CALL REFUS
         CALL MACHIN
         RETURN
      ENDIF
      CALL LIRMOT(LISCOM,2,ival,0)
      call lirobj('RIGIDITE',RI1,1,iretou)
      if( ierr.ne.0) return
      if(IVAL.EQ.0 )THEN
      call lirobj ( 'LISTMOTS',mlmot1,1,iretou)
      if(ierr.ne.0) return
      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
C
      CALL LIRMOT(LISMAT,3,IPLAMA,0)
      CALL LIRMOT(LISMUL,1,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
         call erreur(854)
         segdes mlmot1,mlmot2,mlmot3,mlmot4
      endif
      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

      ENDIF
      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)
         IF (IPLAMA.EQ.1) THEN
            irigel(7,k) = 0
         ELSEIF (IPLAMA.EQ.2) THEN
            irigel(7,k) = 1
         ELSEIF (IPLAMA.EQ.3) THEN
            irigel(7,k) = 2
         ENDIF
      des1=irigel(3,k)
      segini,descr=des1

      irigel(3,k)=descr
      do 1702  ka=1,lisinc(/2)
         if(lisinc(ka).EQ.'LX  '.and.iplmul.eq.0) go to 1702
         do 1703 kb=1,mlmot1.mots(/2)
         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,lisdua(/2)
         if( lisdua(ka).eq.'FLX '.and.iplmul.eq.0) go to 1704
         do 1705 kb=1,mlmot3.mots(/2)
         if( lisdua(ka).eq.mlmot3.mots(kb) ) then
            lisdua(ka)=mlmot4.mots(kb)
            go to 1704
         endif
 1705    continue
 1704 continue
      segdes descr
 1701 continue
      segdes mrigid
      if(ival.eq.0) then
      segdes mlmot1,mlmot2,mlmot3,mlmot4
      else
      segsup mlmot1,mlmot2,mlmot3,mlmot4
      endif
      call ecrobj('RIGIDITE',mrigid)
      return
*
* changement de presentation d'un chargement
* mise sous forme table de chpoint (plus rapide pour l'opérateur TIRE)
*
 2100 call chatab
      return
*
* Changement de la casse d'un mot
*
 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))
      END