C SSCH      SOURCE    CB215821  20/11/25    13:40:22     10792          
      subroutine ssch

ccccccccccccccccccccccccccccccccccccccccccc
c   calcul des terme source si transport par espece
c
c    Ri = ssch tabchi1 Ai SOLU dsol
c
c    Ri terme source nesp chpoi
c    Ai variation sur les composantes fixees ncomp chpoi
c    SOLU concentrations des especes nesp chpoi
c    dsol c1-c2 nesp chpoi
c
cccccccccccccccccccccccccccc
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)

-INC PPARAM
-INC CCOPTIO
-inc SMLENTI
-inc SMLREEL
-inc SMTABLE
-inc SMLMOTS
-inc SMCHPOI
-inc SMELEME
-inc SMCOORD

      pointeur mlaa.mlreel,mlogk.mlreel,mlff.mlreel
      pointeur mlidx.mlenti,mlidy.mlenti,mlnn.mlenti,mldecy.mlenti
      pointeur mlionz.mlenti,mlsolu.mlenti
      pointeur mlidp.mlenti,mlidz.mlenti
      pointeur mlname.mlmots,mlnesp.mlmots
      pointeur izt.mchpoi,izs.mchpoi,mchrij.mchpoi,izd.mchpoi
      pointeur ipt.mpoval,ips.mpoval,ichrij.mpoval,ipd.mpoval

      segment idschi
        real*8 gk(nydim),aa(nydim,nxdim),ff(nzdim,npdim)
        integer idx(nxdim),idy(nydim),idz(nzdim),idp(npdim),nn(6)
        integer idecy(nydim),ionz(nxdim)
        character*32 name(nxdim),namesp(nydim)
      endsegment
      segment sp2
        real*8 gx(nxdim),xx(nxdim),gs(nzdim),ss(nzdim)
        real*8 tot(nxdim),totaq(nxdim),totfix(nxdim),gks(nzdim)
        real*8 yy(nxdim),zz(nxdim,nxdim),cc(nydim),gc(nydim)
      endsegment
      segment iptidx
        integer itdx(nxdim)
      endsegment
      pointeur idxtot.iptidx,idyc.iptidx
      segment iztra
        integer itab(nval),ktab(nn12)
      endsegment

      character*8 ltyp
      character*4 nomtot






c **  lecture table issue de chi1
c
      call chmdeb(mlaa,mlogk,mlff,mlidx,mlidy,mlidz,mlidp,mlnn,mldecy,
     *            mlname,mlionz,itiden,itredo,itempe,mlnesp)

      if(ierr.ne.0) return

c ** recuperation des chpoints
c

      ltyp = 'CHPOINT '
      iretou = 0
      icod = 1
      call lirobj( ltyp , iret, icod,iretou)
      if(iretou.eq.0)return
      izt = iret
      segact izt

      iretou = 0
      icod = 1
      call lirobj( ltyp , iret, icod,iretou)
      if(iretou.eq.0)return
      izs = iret
      segact izs

      iretou = 0
      icod = 1
      call lirobj( ltyp , iret, icod,iretou)
      if(iretou.eq.0)return
      izd = iret
      segact izd


c **  echange eventuel A1 SOLU
c

c ** coherence des support de Ai et SOLU
c

      nsoupo = izt.ipchp(/1)
      if( nsoupo.ne.1) then
        moterr(1:8)= 'CHAMPOIN'
        call erreur(132)
        segdes izt
      endif
      msoupo = izt.ipchp(1)
      segact msoupo
      meleme=igeoc
      indiq=1
      nbcomp =-1
      nomtot='    '
      call quepoi(izs,meleme,indiq,nbcomp,nomtot)
      if(indiq.lt.0) then
        call erreur(22)
      endif
      if(ierr.ne.0)return

      call quepoi(izd,meleme,indiq,nbcomp,nomtot)
      if(indiq.lt.0) then
        call erreur(22)
      endif
      if(ierr.ne.0)return

c **  lecture de la table iden les segments reviennent actifs
c
      call chmide(itiden,mlcomp,mlsolu,mmsolu,mlprec,mmprec,mlsurf,
     *   mmsurf,mltyp3,mmtyp3,mltyp6,mmtyp6,mlparf,mlreac,mlimmo,
     *   mlpole,mmpole,mlsoso,mmsoso,limp3)
      if(ierr.ne.0) return

      segact mlaa,mlogk,mlidx,mlidy,mlnn,mldecy,mlname,mlionz,mlnesp
      segact mlff,mlidz,mlidp
      nxdim=mlidx.lect(/1)
      nydim=mlidy.lect(/1)
      nzdim=mlidz.lect(/1)
      npdim=mlidp.lect(/1)
      segini idschi
      segini sp2

      call chmids(mlaa,mlogk,mlff,mlidx,mlidy,mlidz,mlidp,mlnn,mldecy,
     *             mlname,mlionz,idschi,mlnesp)

      nn12 = mlsolu.lect(/1)
      n1n2 = nn(1) +nn(2)

      nval = nn12 - nxdim
      segini iztra


      moterr(5:8)='TOT '
      call chmlst (izt,mlidx,idxtot,ipt  )

      moterr(5:8)='SOLU'
      call chmmst (izs,mmsolu,idyc  ,ips  )

      segact izs
      msoupo = izs.ipchp(1)
      segact msoupo
      ips = ipoval
      segact ips
      segdes msoupo

      segact izd
      msoupo = izd.ipchp(1)
      segact msoupo
      ipd = ipoval
      segact ipd
      segdes msoupo

      npn = ipt.vpocha(/1)


c ** creation chpoi de resultats
c
      call chmcrc(mmsolu,meleme,npn,mchrij,ichrij)
*     WRITE(IOIMP,*)' chmcrc '

      do 100 ii =1,npn

c ** chargement de idschi
c
      call chmids(mlaa,mlogk,mlff,mlidx,mlidy,mlidz,mlidp,mlnn,mldecy,
     *             mlname,mlionz,idschi,mlnesp)

      do j=1,nxdim
         ipg = idxtot.itdx(j)
        tot(j)=ipt.vpocha(ii,ipg )
      enddo

      ites = 0
      do j=1,nxdim
        if(abs(tot(j)).gt.1.d-31) then
          ites = ites + 1
        endif
      enddo

      if(ites.gt.0) then
      do j=1, nn12
        jpg = idyc.itdx(j)
        cc(j)=ips.vpocha(ii, jpg )
      enddo

      do j =1,nxdim
        idxt = idx(j)
        do k =1,nydim
          if(idy(k).eq.idxt) then
            xx(j) = cc(k)
            go to 10
          endif
        enddo
10      continue
      enddo

      do i=1,nxdim
        do j=1,nxdim
          zz(i,j)=0.d0
          do l=1,nn12
            idyt = mlsolu.lect(l)
            do ll =1,n1n2
              if(idy(ll).eq.idyt) then
            zz(i,j)= zz(i,j) + aa(ll,i) * aa(ll,j) * cc( l) /xx(j)
              go to 20
              endif
            enddo
 20         continue
          enddo
        enddo
      enddo



      iem = 0
      call chmsmq(zz,tot,nxdim,nxdim,iem)

      do l = 1,nn12
        gc(l) = 0.d0
        idyt = mlsolu.lect(l)
        do ll =1,n1n2
          if(idy(ll).eq.idyt) then
            do j =1,nxdim
              gc(l)=gc(l) + aa(ll,j) * cc(l) / xx(j) * tot(j)
            enddo
            go to 40
          endif
        enddo
 40     continue
      enddo

      kk = 0
      do k=1,nn12
              ichrij.vpocha(ii, k)= gc(k)
 30     continue
      enddo

      else
*      do k = 1,nn12
*        ichrij . vpocha(ii,k) = ipd . vpocha(ii,k)
*      enddo
*     endif

*     ioldf = 1
*     if(ioldf.eq.156) then


      if(nval.ge.nxdim) then
      do i = 1 ,nval
        rr = ipd.vpocha(ii,i)
        idyt = mlsolu.lect(i)
        do il = 1,n1n2
           if(idy(il).eq.idyt)then
             do j=1,nxdim
               tot(j) = tot(j) - aa(il,j) * rr
             enddo
             go to 50
           endif
        enddo
 50     continue
      enddo

      do i = nval + 1 , nn12
        idyt = mlsolu.lect(i)
        ik  = i - nval
        do il = 1,n1n2
           if(idy(il).eq.idyt)then
             do j=1,nxdim
               zz(j ,ik) =  aa(il,j)
             enddo
             go to 60
           endif
        enddo
 60     continue
      enddo

      call chmsmq(zz,tot,nxdim,nxdim,iem)

      do k =1,nval
        ichrij.vpocha(ii,k) = ipd.vpocha(ii,k)
      enddo
      do k =  nval+1,nn12
        ik = k - nval
        ichrij.vpocha(ii,k) = tot ( ik)
      enddo
      else

       do i=1,nval
       itab(i)=0
       enddo
       do i=1,nn12
       ktab(i)=0
       enddo
       do j =1,nxdim
         gx(j) = ips.vpocha(ii,j)
         gc(j) = ipd.vpocha(ii,j)
       enddo
       do j=1,nval
         vmi = 100.D0
         do k =1,nxdim
           if(abs(gx(k)).lt.vmi.and.abs(gx(k)).gt.1.d-37) then
             vmi = gx(k)
             im  = k
           endif
         enddo
        gx(im) = 100.D0
        itab(j) = im
        idyt = mlsolu.lect(im)
        rr = ipd.vpocha(ii,im)
         do il = 1,n1n2
           if(idy(il).eq.idyt)then
             do kj=1,nxdim
               tot(kj) = tot(kj) - aa(il,kj) * rr
             enddo
             go to 70
           endif
         enddo
 70      continue
       enddo
      do ik=1,nval
        ktab(itab(ik))=ik
      enddo

      iki = 0
      do i =        1 , nn12
       if(ktab(i).eq.0) then
        idyt = mlsolu.lect(i)
        iki = iki + 1
        do il = 1,n1n2
           if(idy(il).eq.idyt)then
             do j=1,nxdim
               zz(j,iki) =  aa(il,j)
             enddo
             go to 80
           endif
        enddo
 80     continue
       endif
      enddo

      call chmsmq(zz,tot,nxdim,nxdim,iem)

      kk = 0
      do k =1,nn12
        if(ktab(k).ne.0) then
          ki = itab(ktab(k))
          ichrij.vpocha(ii,k) = ipd.vpocha(ii,ki)
        else
          kk = kk+ 1


          ichrij.vpocha(ii,k) = tot ( kk)
        endif
      enddo

      endif


      endif

 100  continue

c **  menage
c
      call ecrobj('CHPOINT ',mchrij)
      mchpoi = mchrij
      msoupo = ipchp(1)
      mpoval = ipoval
      segdes mchpoi,msoupo,mpoval


      segsup idschi
      segsup sp2
      segsup idxtot
      segsup iztra

      segdes mlaa,mlogk,mlidx,mlidy,mlnn,mldecy,mlname,mlionz,mlnesp

      segdes mlsolu
      segdes meleme

        segact izt
       msoupo = izt.ipchp(1)
       segdes msoupo
        segact izs
       msoupo = izs.ipchp(1)
       segdes msoupo
        segact izd
       msoupo = izd.ipchp(1)
       segdes msoupo
      segdes ipt,ips,ipd
      segdes izt,izs,izd

      if(mlimmo.ne.0) then
        mlenti=mlimmo
        segdes mlenti
      endif
      if(mlreac.ne.0) then
        mlenti=mlreac
        segdes mlenti
      endif
      if(mlparf.ne.0) then
        mlenti= mlparf
        segdes mlenti
      endif
      if(mltyp6.ne.0) then
        mlenti=mltyp6
        segdes mlenti
      endif
      if(mltyp3.ne.0) then
        mlenti=mltyp3
        segdes mlenti
      endif
      if(mlsurf.ne.0) then
        mlenti=mlsurf
        segdes mlenti
      endif
      if(mlprec.ne.0) then
        mlenti=mlprec
        segdes mlenti
      endif
      if(mlcomp.ne.0) then
        mlenti=mlcomp
        segdes mlenti
      endif
      if(mmtyp6.ne.0) then
        mlmots=mmtyp6
        segdes mlmots
      endif
      if(mmtyp3.ne.0) then
        mlmots=mmtyp3
        segdes mlmots
      endif
      if(mmsurf.ne.0) then
        mlmots=mmsurf
        segdes mlmots
      endif
      if(mmprec.ne.0) then
        mlmots=mmprec
        segdes mlmots
      endif

        mtab2 =itiden
        segdes mtab2



      return
      end