C MOCA      SOURCE    SP204843  26/02/16    21:15:07     12477          
      subroutine moca
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)

-INC PPARAM
-INC CCOPTIO
-INC CCREEL 
-INC SMLREEL
-INC SMLOBJE
      pointeur mlree4.mlreel, mlree5.mlreel
      character*4 mot(1)
      LOGICAL     LOK1
      segment itra
        integer ipoi(m),npara,ibon(m)
      endsegment
      segment itrav
        real*8  a(n,n),b(n),c(n),bb(n,n)
        integer is(n)
      endsegment
      data MOT /'POID'/
* lecture de la valeur de depart des paramatres
      call lirobj ('LISTREEL',mlpar,1,iretou)
      mlreel=mlpar
      segact mlreel
      nparr = prog(/1)
* lecture de la valeur theorique
      call lirobj('LISTREEL',mlreel,1,iretou)
      if(ierr.ne.0) return
      segact mlreel
      npmes=prog(/1)
* lecture de la valeur de depart
      call lirobj('LISTREEL',mlree1,1,iretou)
      if(ierr.ne.0) return
      segact mlree1
      if(mlree1.prog(/1).ne.npmes) then
      write(ioimp,*)' erreur 0 npmes mlree1.prog', npmes,mlree1.prog(/1)
       call erreur (19)
       return
      endif
* lecture des derivees par rapport au n parametres
*     Cas de la donnee d'un LISTOBJE
      CALL LIROBJ('LISTOBJE',ILOBJ1,0,IRET)
      IF (IRET.NE.0) THEN
        MLOBJE = ILOBJ1
        SEGACT,MLOBJE
        IF (TYPOBJ.NE.'LISTREEL') THEN
          MOTERR(1:8)='LISTREEL'
          CALL ERREUR(1156)
          RETURN
        ENDIF
        NOBJ1 = LISOBJ(/1)
        M = NOBJ1 
        SEGINI,ITRA
        NPARA = 0
        IF (NOBJ1.NE.NPARR) THEN
          INTERR = NPARR
          CALL ERREUR(1157)
          RETURN
        ENDIF
        ZPREC1 = 10.*XZPREC
        DO IO1=1,NOBJ1
          MLREE2 = LISOBJ(IO1)
          SEGACT,MLREE2
          IF (MLREE2.PROG(/1).NE.NPMES) THEN
            INTERR = NPMES
            CALL ERREUR(1158)
            RETURN
          ENDIF
          LOK1 = .FALSE.
          DO IL1=1,MLREE2.PROG(/1)
            XVAL1 = ABS(MLREE2.PROG(IL1))
            LOK1 = XVAL1.GT.((1.-ZPREC1)*XVAL1)
            IF (LOK1) GOTO 30
          ENDDO
 30       CONTINUE
          IF (LOK1) THEN
            IBON(IO1) = 1
            NPARA = NPARA+1
            IPOI(NPARA) = MLREE2
          ENDIF
        ENDDO
      ELSE 
*     Cas de la donnee de plusieurs LISTREEL
        m=100
        segini itra
        NPARA = 0
*        write(ioimp,*) ' nb de parametres ',nparr
        do 1 i=1,nparr
         call lirobj('LISTREEL',mlree2,1,iretou)
         if(ierr.ne.0) then
          write(ioimp,*)  ' erreur 1'
           call erreur (19)
           return
         endif
         segact mlree2
         do iy=1,mlree2.prog(/1)
          if( mlree2.prog(iy).ne.0.d0) go to 10
         enddo
         go to 1
   10    continue
         ibon(i)=1
         if(mlree2.prog(/1).ne.npmes) then
      write(ioimp,*)' erreur 2  npmes mlree2.prog',npmes,mlree2.prog(/1)
           call erreur (19)
           return
         endif
         npara=npara+1
         ipoi(npara)=mlree2
   1    continue
      ENDIF 
      if (npara.eq.0) then
        write(ioimp,*)  ' erreur 3  npara ',npara
        call erreur (21)
        return
      endif
* lecture de l'option POIDS
      call lirmot(mot,1,itrou,0)
      if( itrou.eq.0) then
        jg=npmes
         isup=1
        segini mlree5
        do io=1,npmes
          mlree5.prog(io)=1.d0
        enddo
      else
* lecture du poids
        call lirobj('LISTREEL',mlree5,1,iretou)
        if(ierr.ne.0)return
        segact mlree5
        isup=0
      endif
      n = npara
      segini itrav
      do 3 i=1,npmes
      do 4 j=1,npara
       mlree3=ipoi(j)
       x1=mlree3.prog(i)*2. *mlree5.prog(i)*mlree5.prog(i)
       do 5 k=1,npara
        mlree4=ipoi(k)
        xk=mlree4.prog(i)
        a(j,k)=a(j,k)+x1*xk
   5   continue
       b(j) = b(j) + x1 * ( mlreel.prog(i)-mlree1.prog(i))
   4  continue
   3  continue
*
**  appel a l'inversion
*
*      write(6,*) ' avant inversion'
*      write(6,*) ( a(1,it),it=1,npara)
*      write(6,*) ( a(2,it),it=1,npara)
*      write(6,*) ( a(3,it),it=1,npara)

      diamax=0.
      do io=1,npara
        if( abs(a(io,io)).gt.diamax) diamax=abs(a(io,io))
      enddo
      eps = diamax / 1.e10
      call inver (A,npara,icrit,c,is,eps)
      if(icrit.ne.0) then
       write(ioimp,*) '***** Inversion systeme impossible'
       call erreur(21)
       return
      endif
*      write(6,*) ' apres inversion'
*      write(6,*) ( a(1,it),it=1,npara)
*      write(6,*) ( a(2,it),it=1,npara)
*      write(6,*) ( a(3,it),it=1,npara)

*      write(6,*) ' b '
*      write(6,*) ( b(it),it=1,npara)
      if(isup.eq.1) then
       segsup mlree5
      else
       segdes mlree5
      endif
      jg=npara
      segini mlree5
      do 50 io=1,npara
      mlree5.prog(io)=0.d0
      do 6 iu=1,npara
      mlree5.prog(io)=mlree5.prog(io)+a(io,iu)*b(iu)
   6  continue
  50  continue
*      write(6,*) 'valeur trouvées dans moca'
*      write(6,*) (mlree5.prog(io),io=1,npara)
      segdes mlreel,mlree1
      do io=1,npara
      mlree3=ipoi(io)
      segdes mlree3
      enddo
      jg=nparr
      segini mlreel
      ia=1
      mlree2=mlpar
      do ib=1,nparr
      if(ibon(ib).eq.1)then
      prog(ib)=mlree5.prog(ia) + mlree2.prog(ib)
      ia=ia+1
       else
       prog(ib)=mlree2.prog(ib)
      endif
      enddo
      segdes mlreel,mlree2
      segsup mlree5
      call ecrobj('LISTREEL',mlreel)
      segsup itrav,itra
      return
      end