Télécharger la plaquette Cast3M


fr en

Télécharger vechpo.eso

Retour à la liste

Numérotation des lignes : 

vechpo

  1. C VECHPO    SOURCE    PV        21/11/15    21:15:00     11188          
  2.  
  3.       SUBROUTINE vechpo(ipchp1,ipchp2,ipchp4,ipchp3,ipt8,isouci)
  4. c====================================================================
  5. c       Pour appel par resour
  6. c       verif que ipchp3 est petit devant ipchp1 et ipchp2 et ipchp4
  7. C     erreur:
  8. C           il reste un residu non converti en multiplicateur
  9. C
  10. c====================================================================
  11.  
  12.       IMPLICIT INTEGER(I-N)
  13.       IMPLICIT REAL*8(A-H,O-Z)
  14.  
  15. -INC SMCHPOI
  16. -INC SMELEME
  17. -INC PPARAM
  18. -INC CCOPTIO
  19. -INC CCHAMP
  20. -INC CCREEL
  21. -INC SMCOORD
  22.  
  23.       SEGMENT TEST
  24.         INTEGER IBIN(NBNO,NBCOMP)
  25.       END SEGMENT
  26.       SEGMENT LSCOMP
  27.         CHARACTER*(LOCOMP) LACOMP(NBCOMP)
  28.       ENDSEGMENT
  29.  
  30.       CHARACTER*(LOCOMP) nom2
  31.  
  32.  
  33. **         write(6,*) ' vechpo ipchp1 '
  34. **         call ecchpo(ipchp1,0)
  35. **         write(6,*) ' vechpo ipchp2 '
  36. **         call ecchpo(ipchp2,0)
  37. **         write(6,*) ' vechpo ipchp3 '
  38. **         call ecchpo(ipchp3,0)
  39. **
  40.  
  41. *  preparation ibin qui indique les ddl de ipchp1
  42. *  on ne teste ipchp3 que sur ces ddl
  44.       nbcompo=nbcomp
  45.       segini lscomp
  46.       mchpoi=ipchp1
  47.       segact mchpoi
  48.       do icp=1,ipchp(/1)
  49.        msoupo=ipchp(icp)
  50.        segact msoupo
  51.        nbcomp=nbcompo+nocomp(/2)
  52.        segadj lscomp
  53.         do icomp=1,nocomp(/2)
  54.          do ils=1,ncompo
  55.           if (lacomp(ils).eq.nocomp(icomp)) goto 10
  56.          enddo
  57.          nbcompo=nbcompo+1
  58.          lacomp(nbcompo)=nocomp(icomp)
  59.   10     continue
  60.         enddo
  61.       enddo
  62.       nbcomp=nbcompo+1
  63.       segadj lscomp
  64. **    write(6,*) ' composantes ',(lacomp(i),i=1,lacomp(/2))
  65.       nbno=nbpts
  66.       segini test
  67.       do icp=1,ipchp(/1)
  68.        msoupo=ipchp(icp)
  69.        segact msoupo
  70.        meleme=igeoc
  71.        segact meleme
  72.         do icomp=1,nocomp(/2)
  73.          do ils=1,nbcomp
  74.           if (lacomp(ils).eq.nocomp(icomp)) goto 20
  75.          enddo
  76.   20     continue
  77.          do iel=1,num(/2)
  78.           ibin(num(1,iel),ils)=1
  79.          enddo
  80.         enddo
  81.       enddo
  82.  
  83.  
  84.  
  85.             nbsous=0
  86.             nbref=0
  87.             nbnn=1
  88. *  on multiplie par 1d4 parce qu'on divisera plus trard
  89.       xcrit=xpetit*1d4
  90.       xcritLX=xpetit*1d4
  91.       mchpoi=ipchp1
  92.       segact mchpoi
  93.       do icp=1,ipchp(/1)
  94.        msoupo=ipchp(icp)
  95.        segact msoupo
  96.        mpoval=ipoval
  97.        segact mpoval
  98. **     write(6,*) ' vechpo 1 nocomp ',nocomp(/2),nocomp(1)
  99.        if (nocomp(/2).eq.1.and.nocomp(1).eq.'FLX') then
  100.          do i=1,vpocha(/1)
  101.           xcritlx=max(abs(vpocha(i,1)),xcritlx)
  102.          enddo
  103.        else
  104.          do ic=1,vpocha(/2)
  105.          do i=1,vpocha(/1)
  106.           xcrit=max(abs(vpocha(i,ic)),xcrit)
  107.          enddo
  108.          enddo
  109.        endif
  110.       enddo
  111.       mchpoi=ipchp2
  112.       segact mchpoi
  113.       do icp=1,ipchp(/1)
  114.        msoupo=ipchp(icp)
  115.        segact msoupo
  116.        mpoval=ipoval
  117.        segact mpoval
  118. **     write(6,*) ' vechpo 2 nocomp ',nocomp(/2),nocomp(1)
  119.        if (nocomp(/2).eq.1.and.nocomp(1).eq.'FLX') then
  120.          do i=1,vpocha(/1)
  121.           xcritlx=max(abs(vpocha(i,1)),xcritlx)
  122.          enddo
  123.        else
  124.          do ic=1,vpocha(/2)
  125.          do i=1,vpocha(/1)
  126.           xcrit=max(abs(vpocha(i,ic)),xcrit)
  127.          enddo
  128.          enddo
  129.        endif
  130.       enddo
  131.       mchpoi=ipchp4
  132.       segact mchpoi
  133.       do icp=1,ipchp(/1)
  134.        msoupo=ipchp(icp)
  135.        segact msoupo
  136.        mpoval=ipoval
  137.        segact mpoval
  138. **     write(6,*) ' vechpo 2 nocomp ',nocomp(/2),nocomp(1)
  139.        if (nocomp(/2).eq.1.and.nocomp(1).eq.'FLX') then
  140.          do i=1,vpocha(/1)
  141.           xcritlx=max(abs(vpocha(i,1)),xcritlx)
  142.          enddo
  143.        else
  144.          do ic=1,vpocha(/2)
  145.          do i=1,vpocha(/1)
  146.           xcrit=max(abs(vpocha(i,ic)),xcrit)
  147.          enddo
  148.          enddo
  149.        endif
  150.       enddo
  151.       xcritlx=xcritlx*1d-4 +xpetit/xzprec
  152.       xcrit=xcrit*1d-4  +xpetit/xzprec
  153. **    write(6,*) ' vechpo xcritlx xcrit ',xcritlx,xcrit
  154.       xcrit=max(xcrit,xcritlx)
  155. *
  156. *  test avec ipchp3
  157.       mchpoi=ipchp3
  158.       segact mchpoi
  159.       iwr=0
  160.       do icp=1,ipchp(/1)
  161.        msoupo=ipchp(icp)
  162.        segact msoupo
  163.        mpoval=ipoval
  164.        segact mpoval
  165.         meleme = igeoc
  166.         segact meleme
  167.         do icomp=1,vpocha(/2)
  168.          nom2=nocomp(icomp)
  169.          do j=1,vpocha(/1)
  170. * pas de test sur le moment car probleme d'ordre de grandeur avec les forces
  171.           if(nom2(1:1).ne.'M') then
  172.           if(nom2.ne.'FLX '.and.abs(vpocha(j,icomp)).gt.xcrit) then
  173.            interr(1)=num(1,j)
  174.            moterr(1:4)=nom2
  175.            do ils=1,ncompo
  176.              if (nom2.eq.lacomp(ils)) goto 30
  177.            enddo
  178.   30       continue
  179.            if (ipt8.eq.0) then
  180.              if (isouci.eq.0) then
  181.          iwr=iwr+1
  182.          if (iwr.lt.2) write(6,*) ' vpocha ',vpocha(j,icomp),nom2,xcrit
  183.               call erreur(149)
  184.              else
  185.               call soucis(149)
  186.              endif
  187.            else
  188.             if (ibin(num(1,j),ils).eq.1) then
  189.              nbelem=ipt8.num(/2)+1
  190.              segadj ipt8
  191.              ipt8.num(1,nbelem)=num(1,j)
  192.             endif
  193.            endif
  194.           endif
  195.           endif
  196.          enddo
  197.         enddo
  198.       enddo
  199.       segsup test,lscomp
  200.       return
  201.       end
  202.  
  203.  
  204.  
  205.  
  206.  
  207.  
  208.  
  209.  
  210.  
  211.  
  212.  
  213.  

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