Télécharger la plaquette Cast3M


fr en

Télécharger comail.eso

Retour à la liste

Numérotation des lignes : 

comail

  1. C COMAIL    SOURCE    PV        20/03/30    21:16:18     10567          
  2.       SUBROUTINE COMAIL(iq1,iq2,ielin,ielout,icorre)
  3. * pour 2 meleme de meme type construit un melval en allant piocher
  4. * dans le melval initial si les elements sont les memes
  5. *
  6.       IMPLICIT INTEGER(I-N)
  7.       IMPLICIT REAL*8(A-H,O-Z)
  8.  
  9. -INC PPARAM
  10. -INC CCOPTIO
  11. -INC SMELEME
  12. -INC SMCHAML
  13. -INC SMLENTI
  14. -INC SMCOORD
  15.  
  16.       segment ipos(nbpts+1)
  17.       segment ind(mm)
  18.       segment icorre
  19.          integer mel2(nmel1),icor(nmel1),idej
  20.       endsegment
  21.       logical iperm
  22. *
  23. *
  24.       meleme=iq1
  25.       ipt1=iq2
  26.       ielout=0
  27.       nbsous1 = ipt1.lisous(/1)
  28.       nbnn = num(/1)
  29.       nbnn1 = ipt1.num(/1)
  30.       if (nbsous1.ne.0.OR.nbnn1.ne.nbnn) then
  31. * pas normal
  32.         moterr(1:8) ='COMAIL'
  33.         interr(1) = 1
  34.         call erreur(-329)
  35.         return
  36.       endif
  37.       do iou=1,idej
  38.         if(ipt1.eq.mel2(iou)) then
  39.           if(icor(iou).eq.0) then
  40.             return
  41.           else
  42.             mlenti=icor(iou)
  43. C            segact mlenti
  44.             go to 100
  45.           endif
  46.         endif
  47.       enddo
  48. * on dimensionne au nombre d elements du meleme
  49.       jg= num(/2)
  50.       segini mlenti
  51. * travail preparatoire
  52.       segini ipos
  53.       np=ipos(/1)-1
  54.       do 10 i=1,num(/2)
  55.          do 11 j=1,num(/1)
  56.           ia=num(j,i)
  57.           ipos(ia)=ipos(ia)+1
  58.    11    continue
  59.    10 continue
  60. * on initialise ipos
  61.       do 13 i=2,np
  62.       ipos(i)=ipos(i-1)+ipos(i)
  63.    13 continue
  64.       ipos(np+1)=ipos(np)
  65. * remplissage de ind
  66.       mm=ipos(np)
  67.       segini ind
  68.       do 20 i=1,num(/2)
  69.          do 21 j=1,num(/1)
  70.          ia=num(j,i)
  71.          ide=ipos(ia)
  72.          ind(ide)=i
  73.          ipos(ia)=ipos(ia)-1
  74.    21   continue
  75.    20 continue
  76. *  fin du travail preparatoire
  77.  
  78. C on fabrique le mlenti de correspondance
  79.       ibon=0
  80.       do 15 iel1=1,ipt1.num(/2)
  81.        ia= ipt1.num(1,iel1)
  82.        ideb=ipos(ia)+1
  83.        ifin=ipos(ia+1)
  84.        if(ifin.lt.ideb) go to 15
  85.        do 16 ie=ideb,ifin
  86.          iel=ind(ie)
  87.           do  inn=1,nbnn
  88.               if(num(inn,iel).ne.ipt1.num(inn,iel1))go to 16
  89.           enddo
  90.           ibon=1
  91.            lect(iel)=iel1
  92.           go to 15
  93.   16   continue
  94.   15   continue
  95.        segsup ind,ipos
  96.        idej=idej+1
  97.        if(idej.gt.mel2(/1)) then
  98.         nmel1=mel2(/1)+50
  99.         segadj icorre
  100.       endif
  101.       mel2(idej)=ipt1
  102.       if(ibon.eq.0) then
  103.          return
  104.       endif
  105.       icor(idej)=mlenti
  106. 100   continue
  107.       melva1 = ielin
  108. C      segact melva1
  109.       n1ptel = melva1.velche(/1)
  110.       n1el = num(/2)
  111.       n2ptel = melva1.ielche(/1)
  112.       n2el = num(/2)
  113.       segini melval
  114.        do ielem=1,num(/2)
  115.          iel1=lect(ielem)
  116.             if (n2ptel.eq.0.and.n2el.eq.0) then
  117.               do iptel = 1, n1ptel
  118.                 velche(iptel,ielem) = melva1.velche(iptel,iel1)
  119.               enddo
  120.             elseif (n1ptel.eq.0.and.n1el.eq.0) then
  121.               do iptel = 1,n2ptel
  122.                 ielche(iptel,ielem) = melva1.ielche(iptel,iel1)
  123.               enddo
  124.             endif
  125.        enddo
  126. C      segdes,melva1
  127.       segact,melval
  128.       ielout=melval
  129.       RETURN
  130.       END
  131.  
  132.  
  133.  
  134.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales