C PROIET    SOURCE    GF238795  13/11/05    21:15:02     7824           

      SUBROUTINE PROIET

C--------------------------------------------------------------------
C
C                         OPERATEUR PROIET
C--------------------------------------------------------------------
C
C     
C       PROJECTION  D'UN CHAMELEM AUX NOEUDS DUN MAILLAGE 
C       PROJECTION ET VALEUR D'UN CHAMELEM AUX NOEUDS OU AUX
C    POINTS D INTEGRATION  D UN MODELE POUVANT COMPORTER DES COQUES
C    INTEGREES (LA COMPOSANTE T  SI PRESENTE SERA  DECOMPOSEE
C    EN T TINF TSUP SI NECESSAIRE SUIVANT LA FORMULATION DE LA COQUE 
C       PROJECTION  D'UN CHAMELEM PAR MINIMISATION DE L INTEGRALE
C 
C            INT (U1i - U2i)**2  SUR LES ELEMENT RECEPTEURS 
C
C
C
C     - 'POLY' :
C            PROJECTION SUR GEO2 DES COMPOSANTES D'UN CHPOINT CHP1
C            DEFINI SUR GEO1 PAR UNE METHODE DE LISSAGE ( adaptee
C            pour des champs magnetostatique) 
C
C SYNTAXE :
C
C      CHPO1    = PROIET    MAIL2   CHEL1                     
C                                           
C      MCHEL1    = PROIET    MOD1   (CARA )   CHEL1 (MOD2)
C             
C      MCHEL1    = PROIET    MOD1   CHEL1  (MOD2)  (MINI  (NB ))
C   
C      OBJ1    = "POLY" GEO1 GEO2 CHP1 ENT1 MOT1 ("POIDS" X1 X2)
C                
C
C ENTREE :
C   SANS OPTION :
C                 MAIL2 = OBJET DE TYPE MAILLAGE.
C
C                 CHEL1 = OBJET DE TYPE  MCHAML.                
C  
C                 MOD1 = MODELE 
C                 CARA = CARACTERISTIQUE DE LA COQUE (MCHAML) si il y a des
C       des sous zones coques dans le modele 
C
C   POLY :
C                 GEO1 = OBJET DE TYPE MAILLAGE
C                 GEO2 = OBJET DE TYPE MAILLAGE
C                 CHP1 = OBJET DE TYPE MCHAML
C                 ENT1 = ENTIER (PRECISE LE TYPE DE SYMETRIE)
C                 MOT1 = MOT 'PLAN' OU 'AXIS'
C                 POIDS = MOT FACULTATIF
C
C SORTIE   :
C
C
C
C     NORA DAVIDOVICH- 15/2/89
C     NOUVEAUX CHAMELEMS P DOWLATYARI OCT. 91
C     MODIFICATION FLEURET 01/96 - OPTION 'ARMA'
C     MODIFICATION VIGAN   03/97 - OPTION 'COQU'
C--------------------------------------------------------------------
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
-INC CCOPTIO
-INC SMCHAML
-INC SMMODEL
** pile modeles elementaires
      segment limode(0)

      PARAMETER (NCLE = 7)
      CHARACTER*4 MOTCLE(NCLE)

      DATA  MOTCLE /'POLY','NOEU','GRAV','RIGI','MASS','STRE','MINI'/

C-----LECTURE DE L'OPTION
      IVAL = 0
      CALL LIRMOT(MOTCLE,NCLE,IVAL,0)
C
C-----OPTION POLY
      IF (IVAL.EQ.1)  THEN
        CALL LISSAG
        RETURN
      ENDIF

C- Par defaut, le support est aux noeuds
      IF (IVAL.EQ.0) IVAL = 2

      IPGEA = 0
      CALL LIROBJ('MAILLAGE',IPGEA,0,iretou)
      IF (IERR.NE.0) RETURN

C- Projection d'un champ par element defini aux noeuds sur un maillage
      IF (IPGEA.GT.0) THEN 

        CALL LIROBJ('MCHAML',IPCHEL,1,iretou)
        IF (IERR.NE.0) RETURN
C Verification du support aux noeuds
        CALL QUESUP(0,IPCHEL,0,1,iretou,iret2)
        IF (iretou.GT.1) THEN
          CALL ERREUR(903)
          RETURN
        ENDIF

        CALL PRO2(IPGEA,IPCHEL,1, IPOUT,-1)

        IF (IERR.EQ.0) CALL ECROBJ('CHPOINT',IPOUT)

        RETURN

C- Projection d'un champ par element aux noeuds sur le support d'un modele
c*      ELSE IF (IPGEA.EQ.0) THEN 
      ELSE
        CALL LIROBJ('MMODEL',ipmod1,1,iretou)
        IF (IERR.NE.0) RETURN
        CALL LIROBJ('MCHAML',IPCHE1,1,iretou)
        IF (IERR.NE.0) RETURN
        CALL LIROBJ('MCHAML',IPCHE2,0,iretou)
        IF (IERR.NE.0) RETURN

        IF (IPCHE2.NE.0) THEN
          IPCHEL = IPCHE2
          IPCARA = IPCHE1
        ELSE
          IPCHEL = IPCHE1
          IPCARA = 0
        ENDIF
C Cas particulier de la presence d'un champ de CARACTERISTIQUES
C On permute eventuellement l'ordre mais normalement il faut respecter 
C l'ordre de la notice "IPCARA IPCHEL"
        IF (IPCARA.NE.0) THEN
          mchelm = IPCARA
          SEGACT,mchelm
          IF (titche(1:16).NE.'CARACTERISTIQUES') THEN
c le champ de caracteristiques a peut etre ete donne en deuxieme, on
c teste en inversant les deux champs par elements fournis
             SEGDES,mchelm
             IPCHEL = IPCHE1
             IPCARA = IPCHE2

             mchelm = IPCARA
             SEGACT,mchelm
             IF (titche(1:16).NE.'CARACTERISTIQUES') THEN
               SEGDES,mchelm
               MOTERR(1:16) = 'CARACTERISTIQUES'
               CALL ERREUR(565)
             ENDIF
          ENDIF
          SEGDES,mchelm
          IF (IERR.NE.0) RETURN
        ENDIF
C Verification du support aux noeuds
        CALL QUESUP(0,IPCHEL,0,1,iretou,iret2)
        IF (iretou.GT.1) THEN
          CALL ERREUR(903)
          RETURN
        ENDIF

* kich : pour MELANGE on deroule les modeles
        mmodel = ipmod1
        SEGACT,mmodel*nomod
        NSOUS = kmodel(/1)
        IF (NSOUS.LE.0) THEN
          SEGDES,mmodel
          CALL ERREUR(5)
          RETURN
        ENDIF
*
        limode=0
        SEGINI,limode
        DO im1 = 1, NSOUS
          imodel = kmodel(im1)
          SEGACT,imodel
          limode(**) = imodel
          IF (formod(1).EQ.'MELANGE') THEN
            IF (matmod(1).NE.'SERIE') THEN
              IF (ivamod(/1).GE.1) then
                DO im2 = 1, ivamod(/1)
                  IF (tymode(im2).eq.'IMODEL') then 
                    limode(**) = ivamod(im2)
                    imodel = ivamod(im2)
                    SEGACT,imodel
                  ENDIF
                ENDDO
              ENDIF
            ENDIF
          ENDIF
        ENDDO
        SEGDES,mmodel
*
        NSOUS = limode(/1)
* test non redondance
        N1 = 1
        DO 10 im1 = NSOUS, 2, -1
          imode1 = limode(im1)
          DO im2 = (im1 - 1), 1, -1
            imode2 = limode(im2)
            IF (imode1.EQ.imode2) THEN
              limode(im1) = 0
              GOTO 10
            ELSE IF (imode1.imamod.EQ.imode2.imamod .AND.
     &               imode1.conmod.EQ.imode2.conmod) THEN
              limode(im1) = 0
              SEGDES,imode1
              GOTO 10
            ENDIF
          ENDDO
          N1 = N1 + 1
 10     CONTINUE
        SEGINI,mmodel
        im1 = 0 
        DO im2 = 1, NSOUS
          imode2 = limode(im2)
          IF (imode2.GT.0) THEN
            im1 = im1 + 1  
            kmodel(im1) = imode2
          ENDIF
        ENDDO
        ipmod1 = mmodel
        SEGSUP,limode
C
        ISUP = 1
C- Option 'MINI'
        IF (IVAL.EQ.7) THEN
          CALL PROM(ipmod1,IPCARA,IPCHEL,ISUP, IPOUT)
C- Projection sur support ISUP
        ELSE
          IF (IVAL.GT.1.AND.IVAL.LT.7) ISUP = IVAL-1
          CALL PRON(ipmod1,IPCARA,IPCHEL,ISUP, IPOUT)
        ENDIF

        IF (IERR.EQ.0) CALL ECROBJ('MCHAML',IPOUT)

      ENDIF

      RETURN
      END