Télécharger dans.eso

Retour à la liste

Numérotation des lignes :

  1. C DANS SOURCE PV 13/04/12 21:15:23 7756
  2. C teste si un listentier dans un autre
  3. subroutine dans
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8(A-H,O-Z)
  6. -INC CCOPTIO
  7. -INC SMLENTI
  8. -INC SMLREEL
  9. -INC SMELEME
  10. character*4 chaopt(2)
  11. data chaopt/'SEQU','QUEL'/
  12. c
  13. c premiere option un listenti dans un autre
  14. c
  15. imo=0
  16. call lirmot(chaopt,2,imo,0)
  17. call lirobj('LISTENTI',mlent1,0,iretou)
  18. if( iretou.eq.0) go to 100
  19. call lirobj('LISTENTI',mlent2,1,iretou)
  20. if (ierr.ne.0) return
  21. segact mlent1,mlent2
  22. lon=mlent1.lect(/1)
  23. do 10 i=0,mlent2.lect(/1)-1,lon
  24. do 20 j=1,lon
  25. if (mlent1.lect(j).ne.mlent2.lect(i+j)) goto 30
  26. 20 continue
  27. * ok on a trouve
  28. call ecrlog(.true.)
  29. segdes mlent1,mlent2
  30. return
  31. 30 continue
  32. 10 continue
  33. call ecrlog(.false.)
  34. segdes mlent1,mlent2
  35. return
  36. 100 call lirobj('LISTREEL',mlree1,0,iretou)
  37. if (iretou.eq.0) go to 300
  38. if( ierr.ne.0) return
  39. call lirobj('LISTREEL',mlree2,0,iretou)
  40. if( iretou.eq.0) go to 200
  41. C
  42. C deuxieme option un listreel dans un autre listreel
  43. c
  44. prec = 1.d30
  45. segact mlree1,mlree2
  46. lon = mlree2.prog(/1)
  47. do 101 i=1,lon-1
  48. prec = min ( prec ,abs (mlree2.prog(i)-mlree2.prog(i+1)))
  49. 101 continue
  50. prec=prec/ 1.d5
  51. IF(IMO.ne.2) then
  52. * option sequentiel
  53. lon = mlree1.prog(/1)
  54. do 110 i=0,mlree2.prog(/1)-1,lon
  55. do 120 j=1,lon
  56. if (abs(mlree1.prog(j)-mlree2.prog(i+j)).gt.prec) goto 130
  57. 120 continue
  58. * ok on a trouve
  59. call ecrlog(.true.)
  60. segdes mlree1,mlree2
  61. return
  62. 130 continue
  63. 110 continue
  64. call ecrlog(.false.)
  65. segdes mlree1,mlree2
  66. return
  67. else
  68. * option quel
  69. do 140 i=1,mlree1.prog(/1)
  70. ab = mlree1.prog(i)
  71. do 150 j=1,mlree2.prog(/1)
  72. if( abs(mlree2.prog(j)-ab) . le. prec) go to 140
  73. 150 continue
  74. call ecrlog(.false.)
  75. segdes mlree1,mlree2
  76. return
  77. 140 continue
  78. call ecrlog(.true.)
  79. segdes mlree1,mlree2
  80. return
  81. endif
  82. 200 call lirree(xva,0,iretou)
  83. if(iretou.eq.0) then
  84. call erreur(21)
  85. endif
  86. c
  87. c test si un reel est dans un listreel
  88. c
  89. prec = 1.d30
  90. segact mlree1
  91. lon = mlree1.prog(/1)
  92. do 201 i=1,lon-1
  93. if(mlree1.prog(i)-mlree1.prog(i+1).eq.0.d0)go to 201
  94. prec = min ( prec ,abs (mlree1.prog(i)-mlree1.prog(i+1)))
  95. 201 continue
  96. prec= prec / 1.d5
  97. do 202 i=1,lon
  98. if( abs ( xva - mlree1.prog(i)).lt. prec) go to 203
  99. 202 continue
  100. call ecrlog(.false.)
  101. segdes mlree1
  102. return
  103. 203 call ecrlog(.true.)
  104. segdes mlree1
  105. return
  106.  
  107. 300 continue
  108. call lirobj('POINT',ip1,1,iretou)
  109. if (ierr.ne.0) return
  110. call lirobj('MAILLAGE',meleme,0,iretou)
  111. if(iretou.eq.0) then
  112. call erreur(21)
  113. endif
  114. call ecrobj('MAILLAGE',meleme)
  115. call ecrcha('POI1')
  116. call prchan
  117. call lirobj('MAILLAGE',meleme,0,iretou)
  118. if (ierr.ne.0) return
  119. segact meleme
  120. do kp=1,num(/2)
  121. if (ip1.eq.num(1,kp)) then
  122. call ecrlog(.true.)
  123. return
  124. endif
  125. enddo
  126. call ecrlog(.false.)
  127. return
  128. end
  129.  
  130.  
  131.  
  132.  
  133.  
  134.  
  135.  
  136.  

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