C PROJTA    SOURCE    BP208322  13/12/02    21:15:01     7870           
      SUBROUTINE PROJTA(IP1,IP2,IRET)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
************************************************************************
*                                                                      *
*     PROJECTION DU CHAMP IP1 SUR LES ELEMENTS DE LA BASE MODALE IP2   *
*                                                                      *
*     PARAMETRES:                                                      *
*                                                                      *
* E   ip1     chpoint                                                  *
* E   it2     table des modes de sous-type base_de_modes               *
* S   iret    chpoint resultat                                         *
*                                                                      *
*     REMARQUES:                                                       *
*                                                                      *
*     ce sous-programme est une copie de projba                        *
*     ce sous-programme est appele par pjba, psmo, copba4              *
*                                                                      *
*     AUTEUR, DATE DE CREATION:                                        *
*                                                                      *
*     lionel vivan       aout 1990                                     *
*                                                                      *
************************************************************************
*
-INC CCOPTIO
-INC CCGEOME
-INC CCREEL
-INC SMCHPOI
-INC SMELEME
-INC CCHAMP
*
      SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
      SEGMENT IINC
       CHARACTER*4 CIINC(0)
      ENDSEGMENT
      SEGMENT IIDU
       CHARACTER*4 CIIDU(NNI1)
      ENDSEGMENT
      SEGMENT/MVA/(VA(NNI1,IPR1)*D),MVA1.MVA
      SEGMENT IPB(IPR1)
      SEGMENT MCONTR(NNI1,IPR1)
      LOGICAL L0,L1
      CHARACTER*4 IDDL
      CHARACTER*8 TYPRET,CHARRE
      DATA KZERO/0/
c
      IRET = 0
c
c   deplacement impose => idepi=1
c   force imposee      => idepi=0
c
      IDEPI =  0
c     idepi = -1
      KDEPI =  0
      MCHPOI = IP1
      SEGACT MCHPOI
      IF (MTYPOI.EQ.'FLX     ') IDEPI = 1
c     if(mtypoi(1).eq.moforc(1).and.mtypoi(2).eq.moforc(2)) idepi=0
      SEGDES MCHPOI
c     if (idepi.lt.0) then
c        moterr(1:8) = 'chpoint'
c        call erreur(302)
c        return
c     endif
c
      NBNN   = 1
      NBREF  = 0
      NBSOUS = 0
*
      LDEPL = 0
 10   CONTINUE
      LDEPL = LDEPL + 1
      TYPRET = ' '
      CALL ACCTAB(IP2,'ENTIER',LDEPL,X0,' ',L0,IP0,
     &                TYPRET,I1,X1,CHARRE,L1,ITMOD)
      IF (TYPRET.EQ.'TABLE   ' .AND. ITMOD.NE.0) GOTO 10
      LDEPL = LDEPL - 1
c
c  **** etalpr du chpoint de la solution
c
      IND = 1
      CALL ACCTAB(IP2,'ENTIER',IND,X0,' ',L0,IP0,
     &                'TABLE',I1,X1,'  ',L1,ITMOD)
      CALL ACCTAB(ITMOD,'MOT',I0,X0,'DEFORMEE_MODALE',L0,IP0,
     &                  'CHPOINT',I1,X1,'  ',L1,IPM)
      CALL ETALPR(IPM,KIINC,KICPR,KCONTR)
      IF (IERR.NE.0) RETURN
      MCONTR = KCONTR
      SEGACT MCONTR
      NNI1 = MCONTR(/1)
      IPR1 = MCONTR(/2)
      SEGDES MCONTR
      SEGINI MVA
      KMVA = MVA
      SEGDES MVA
      SEGINI MVA
      KMVB = MVA
      SEGDES MVA
      SEGINI IPB
      KIPB = IPB
      SEGDES IPB
*     fabrication de la liste des inconnues duales correspondant aux primales      
      IINC = KIINC
      SEGACT IINC
      SEGINI IIDU
      DO 6 I = 1,NNI1
         IDDL = CIINC(I)
         DO 7 J = 1,LNOMDD
            IF(IDDL.NE.NOMDD(J)) GOTO 7
            CIIDU(I) = NOMDU(J)
            GOTO 6
 7       CONTINUE
         MOTERR(1:4) = IDDL
         CALL ERREUR(108)
c        on ne trouve pas iddl dans CCHAMP
         RETURN
 6    CONTINUE
      SEGDES IINC,IIDU
      KINCDU = IIDU
c
c  **** on regarde si les points de f correspondent
c  **** on met f dans kmvb
c
      CALL ETALCH(IP1,KINCDU,KICPR,KCONTR,KMVB,KIPB,NPR2)
      IF (IERR.NE.0) RETURN
c
c  **** on initialise le chpoint
c
      NSOUPO = 1
      NAT=1
      SEGINI,MCHPOI
      IRET = MCHPOI
      MTYPOI = '        '
      MOCHDE=' J''AI ETE FABRIQUE PAR L''OPERATEUR PROJTA'
      IFOPOI = IFOUR
*     champ de force nodal: nature discrete
      JATTRI(1)=2
      NC = 1
      SEGINI,MSOUPO
      IPCHP(1)  = MSOUPO
      NOCOMP(1) = 'FALF'
      NOHARM(1) = NIFOUR
      N = LDEPL
      SEGINI MPOVAL
      IPOVAL = MPOVAL
*
      NBNN = 1
      NBELEM = LDEPL
      NBSOUS = 0
      NBREF = 0
      SEGINI MELEME
      IGEOC = MELEME
      ITYPEL = 1
c
c  ****boucle sur les chpoints de depl
c
      DO 11 IM = 1,LDEPL
         CALL ACCTAB(IP2,'ENTIER',IM,X0,' ',L0,IP0,
     &                   'TABLE',I1,X1,'  ',L1,ITMOD)
         CALL ACCTAB(ITMOD,'MOT',I0,X0,'POINT_REPERE',L0,IP0,
     &                     'POINT',I1,X1,'  ',L1,IPTR)
         NUM(1,IM) = IPTR
         ICOLOR(IM) = IDCOUL
         CALL ACCTAB(ITMOD,'MOT',I0,X0,'DEFORMEE_MODALE',L0,IP0,
     &                     'CHPOINT',I1,X1,'  ',L1,IPP1)
         XRET = 0.D0
         IF (IDEPI.NE.1) THEN
            CALL ETALCH(IPP1,KIINC,KICPR,KCONTR,KMVA,KZERO,IBID)
            IF (IERR.NE.0) RETURN
*
            MVA = KMVA
            IPB = KIPB
            MVA1 = KMVB
            SEGACT MVA,MVA1,IPB
            DO 80 J1 = 1,NPR2
               JJ1 = IPB(J1)
               DO 80 I1 = 1,NNI1
                  XRET = XRET + VA(I1,JJ1) * MVA1.VA(I1,JJ1)
 80         CONTINUE
            SEGDES MVA,MVA1,IPB
         ELSE
            CALL ACCTAB(ITMOD,'MOT',I0,X0,'FREQUENCE',L0,IP0,
     &                        'FLOTTANT',I1,X1,'  ',L1,IP1)
             OM = X1
             OM = 2.D0 * XPI * OM
             OM = OM * OM
             XRET = -XRET / OM
cbp          XRET vaut toujours 0 !?!?!
         ENDIF
cbp         IF (IFOUR .EQ. 1) THEN
cbp             IF (NIFOUR .NE. 0) THEN
cbp                XRET = XRET*XPI
cbp             ELSE
cbp                XRET = XRET*2.D0*XPI
cbp             ENDIF
cbp         ENDIF
*         if (ifour .eq. 0) xret = xret*2.d0*xpi
       VPOCHA(IM,1) = XRET

 11   CONTINUE
*
      SEGSUP MVA,MVA1,IPB
      ICPR = KICPR
      SEGSUP ICPR,IINC,IIDU
*
      SEGDES MPOVAL,MELEME
      SEGDES MSOUPO
      SEGDES MCHPOI
      IF (IDEPI.NE.KDEPI) THEN
***      la base ne contient pas la solution statique necessaire au
***      calcul de la reponse au deplacement impose
         CALL ERREUR(303)
         CALL ECRCHA('GEOM')
         CALL DTCHPO(MCHPOI)
         IRET = 0
      ENDIF
*
      END