Sources Esope | Cast3M

confor
C CONFOR    SOURCE    CB215821  24/04/12    21:15:27     11897          
      subroutine confor(mchelm,mchel1,mmodel,iprio)
      implicit real*8(a-h,o-z)
      implicit integer  (i-n)
-INC SMMODEL
-INC SMCHAML
 
-INC PPARAM
-INC CCOPTIO
*
* verifie que dans un chamelem pas plus de zones que dans le modele
* si c'est le cas essaye de regrouper les zones du chaml s'appuyant
* sur le meme modele en prenant iprio comme lieu de support
*
      segment lijk
        integer imail(no),isu(no),ipla(no),igard(nch)
        character*16 ncom(no),npha(no)
      endsegment
      character*16 icom,iph
*      write(6,*) ' entrée dans confor '
      nmo=kmodel(/1)
      nch=imache(/1)
      no=nmo
      n1=1
      segini lijk
      n3=infche(/2)
      l1 = titche(/1)
      segini,mchel1=mchelm
*      write(6,*) ' nmo nch ', nmo,nch
*        write(6,*) ' pour le modele imamod conmod phamod'
 
      do 1 io=1,nmo
        imodel=kmodel(io)
*        write (6,*) imamod,conmod,phamod
        imail(io)=imamod
        ncom(io)=conmod
        npha(io)=conmod(17:24)
    1 continue
 
*      write(6,*) ' boucle sur le chamelem  '
      do 2 io=1,nch
        ima=imache(io)
        icom=conche(io)
        iph=conche(io)(17:24)
        mcham1=ichaml(io)
*         write(6,*) ' nomche ',(mcham1.nomche(ic),ic=1,
*     $  mcham1.nomche(/2))
*         write(6,*) ima, icom,iph
        do 3 iu=1,nmo
         if( ima.eq.imail(iu)) then
           if(icom.eq.ncom(iu)) then
             if(iph.eq.npha(iu)) then
* on a trouvé sur quelle partie du modele on s'appuie
* on teste si deja rencontré et si oui on met tout le monde
* sur le support iprio
               if(isu(iu).ne.0) then
                  isune=infche(io,6)
                  if(isu(iu).ne.iprio.and.isu(iu).ne.isune) then
* il faut changer le support du ipla(iu)
                    ia = ipla(iu)
*                    write(6,*) ' ia iu',ia,iu
                    segini mmode1
                    mmode1.kmodel(1)=kmodel(iu)
                    segini mchel2
                    mchel2.CONCHE(1)=conche(Ia)
                    mchel2.IMACHE(1)=imache(ia)
                    mchel2.IMACHE(1)=imache(ia)
                    mchel2.ICHAML(1)=ICHAML(ia)
                    mchel2.ifoche=ifoche
                    mchel2.titche=titche
                    do iy=1,n3
                     mchel2.infche(1,iy)=infche(ia,iy)
                    enddo
*                    write(6,*) ' confor appel a chasup'
                    call chasup(mmode1,mchel2,mchel3,irt,iprio)
                    isu(iu)=iprio
                    if(irt.ne.0) return
                    mchel1.ichaml(ia)=mchel3.ichaml(1)
                    mchel1.infche(ia,6)=mchel3.infche(1,6)
                    segsup mchel2,mmode1
                  endif
* il suffit d'additionner au ipla(iu )ieme  ( si pas bon support
*   faire un chasup)
*                  write(6,*) ' passage 2  io '
                  ia=io
                  segini mchel2
                  mchel2.CONCHE(1)=conche(Ia)
                  mchel2.IMACHE(1)=imache(ia)
                  mchel2.ICHAML(1)=ICHAML(ia)
                  mchel2.ifoche=ifoche
                  mchel2.titche=titche
                  do iy=1,n3
                    mchel2.infche(1,iy)=infche(ia,iy)
                  enddo
                  if(infche(io,6).ne.isu(iu)) then
                    n1=1
                    isuppr=1
                    segini mmode1
                    mmode1.kmodel(1)=kmodel(iu)
*                    write(6,*) ' confor appel a chasup  2'
                    call chasup(mmode1,mchel2,mchel3,irt,iprio)
                    segsup mmode1,mchel2
                  else
                    isuppr=0
                    mchel3=mchel2
                  endif
                  ib=ipla(iu)
*                  write(6,*) ' ib iu ' , ib,iu
                  mchaml=mchel1.ichaml(ib)
                  segini,mcham4=mchaml
                  mchaml=mcham4
                  mchel1.ichaml(ib)=mchaml
                  n22= ielval(/1)
                  mcham3=mchel3.ichaml(1)
                  n4=mcham3.ielval(/1)
                  n2=n22+n4
                  segadj mchaml
*                  write(6,*) ' n2 n22 n4 ', n2 , n22 , n4
                  do iy=1,n4
                    mchaml.nomche(iy+n22)=mcham3.nomche(iy)
                    mchaml.typche(iy+n22)=mcham3.typche(iy)
                    mchaml.ielval(iy+n22)=mcham3.ielval(iy)
                  enddo
                  if(isuppr.eq.1) segsup mchel3,mcham3
               else
* on se contente de stocker le champ
                  isu(iu)=infche(io,6)
                  ipla(iu)=io
                  igard(io)=1
*                 write(6,*) ' iu io',iu,io
               endif
               go to 2
             endif
           endif
         endif
    3   continue
        call erreur( 19)
        return
    2 continue
*
* il ne reste plus qu'a tasser mchel1
*
       ico=0
       do iy=1,nch
        if(igard(iy).eq.1) then
          ico=ico+1
          do ip=1,n3
           mchel1.infche(ico,ip)=mchel1.infche(iy,ip)
          enddo
          mchel1.conche(ico)=mchel1.conche(iy)
          mchel1.imache(ico)=mchel1.imache(iy)
          mchel1.ichaml(ico)=mchel1.ichaml(iy)
        endif
       enddo
       if(ico.ne.nch) then
         n1=ico
         l1=mchel1.titche(/1)
         n3= mchel1.infche(/2)
         segadj mchel1
        endif
*       if(ico.ne.no) call erreur(19)
       segsup lijk
 
       end