C MOCA      SOURCE    CHAT      05/01/13    01:46:52     5004           
      subroutine moca
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
-INC CCOPTIO
-INC SMLREEL
      pointeur mlree4.mlreel, mlree5.mlreel
      character*4 mot(1)
      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(6,*)' erreur 0 npmes mlree1.prog', npmes,mlree1.prog(/1)
       call erreur (19)
       return
      endif   
      m=100
      segini itra
*      write(6,*) ' nb de parametres ',nparr
      do 1 i=1,nparr
* lecture des sensibilité par rapport au n parametres
       call lirobj('LISTREEL',mlree2,1,iretou)
       if(ierr.ne.0) then
        write(6,*)  ' 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(6,*)' erreur 2  npmes mlree2.prog', npmes,mlree2.prog(/1)
         call erreur (19)
         return
       endif
       npara=npara+1
       ipoi(npara)=mlree2      
   1  continue
      if( npara.eq.0) then
        write(6,*)  ' erreur 3  npara ',npara
        call erreur (19)
       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
       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