Télécharger dans.eso

Retour à la liste

Numérotation des lignes :

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

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