Télécharger hatrig.eso

Retour à la liste

Numérotation des lignes :

  1. C HATRIG SOURCE PV 16/11/26 21:15:55 9205
  2. SUBROUTINE HATRIG (ICOLAC)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. C-----------------------------------------------------------------------
  6. C
  7. C BUT :VA A LA PECHE DES CHAPEAUX DES OBJETS RIGIDITES
  8. C DEJA CONTENUS DANS LES PILES
  9. C LOGIQUE:
  10. C ON SE POINTE SUR LA PILE
  11. C ON CREE LA TABLE DES OBJETS DU TYPE DE CETTE PILE
  12. C-- CAS GENERAL
  13. C ON TESTE SI LE POINTEUR DANS L OBJET EST DANS LA PILE
  14. C SI OUI, ON PASSE A L OBJET SUIVANT.
  15. C SI NON
  16. C
  17. C
  18. C SI L ENSEMBLE DES POINTEURS EST CONTENU DANS LE ITLAC ASSOCIE
  19. C ALORS ON RAJOUTE L OBJET DANS LA PILE , CE QUI OBLIGE A UN
  20. C RAPPEL DE FILLPI
  21. C
  22. C PROGRAMME PAR : FARVACQUE-REPRIS PAR LENA
  23. C APPELE PAR : SAUV
  24. C APPELLE : SORT7 SORT8 ERREUR REPERT
  25. C
  26. C=======================================================================
  27. C TABLEAU KCOLA :
  28. C 1 MELEME 2 CHPOIN 3 MRIGID 4 MCHAFF 5 MCHELM 6 MCLSTR
  29. C 7 MELSTR 8 MSOLUT 9 MSTRUC 10 11 MAFFEC 12 MSOSTU
  30. C 13 IMATRI 14 MJONCT 15 MATTAC 16 MMATRI 17 MDEFOR 18 MLREEL
  31. C 19 MLENTI 20 MCHARG 21 MODELE 22 MEVOLL
  32. C=======================================================================
  33. C
  34. -INC SMRIGID
  35. -INC CCOPTIO
  36. -INC TMCOLAC
  37. SEGMENT ILISBB
  38. INTEGER ILISOB(MLON)
  39. ENDSEGMENT
  40. DIMENSION IBID(1)
  41. C
  42. CHARACTER*(8) ITYPE
  43. C
  44. SEGACT ICOLAC
  45. ILISSE=ILISSG
  46. SEGACT ILISSE*MOD
  47. C
  48. C
  49. C **************************** MRIGID ******************************
  50. C
  51. IFILE=0
  52. ITYPE='RIGIDITE'
  53. CALL TYPFIL (ITYPE,IFILE)
  54. ITLACC=KCOLA(IFILE)
  55. IMAX1=ITLAC(/1)
  56. IF(IMAX1.EQ.0) GO TO 600
  57. CALL LISTOB(ITYPE,MLON,IBID,0)
  58. SEGINI ILISBB
  59. CALL LISTOB(ITYPE,N,ILISOB,1)
  60. C LA PILE N EST PAS VIDE-------------------------------
  61. C CALL REPERT (ITYPE,N)
  62. IF (N.EQ.0) GO TO 599
  63. ITLAC1=KCOLA(1)
  64. ITLAC2=KCOLA(11)
  65. ITLAC3=KCOLA(13)
  66. C
  67. DO 1500 I =1,N
  68. MRIGID = ILISOB(I)
  69. C CALL LIROBJ(ITYPE,MRIGID,1,IRETOU)
  70. CALL SNOM2(MRIGID,ITLACC,IRET)
  71. IF(IRET.NE.0) GOTO 1500
  72. C --- ON RECHERCHE PLUS PROFONDEMENT
  73. SEGACT MRIGID
  74. NRIGEL=IRIGEL(/2)
  75. DO 1501 IR=1,NRIGEL
  76. DO 1502 J=1,IMAX1
  77. RI1=ITLAC(J)
  78. if(ri1.eq.0) goto 1502
  79. SEGACT RI1
  80. NRIGE1=RI1.IRIGEL(/2)
  81. DO 1503 K=1,NRIGE1
  82. C KK=ITLAC1.ITLAC(RI1.IRIGEL(1,K))
  83. C IF(IRIGEL(1,IR).NE.KK) GOTO 1503
  84. C IF(RI1.IRIGEL(2,K).EQ.0) THEN
  85. C KK=0
  86. C ELSE
  87. C KK=ITLAC2.ITLAC(RI1.IRIGEL(2,K))
  88. C ENDIF
  89. C IF(IRIGEL(2,IR).NE.KK) GOTO 1503
  90. C KK=ITLAC3.ITLAC(RI1.IRIGEL(4,K))
  91. C IF(IRIGEL(4,IR).NE.KK) GOTO 1503
  92. IF(IRIGEL(4,IR).NE.RI1.IRIGEL(4,K)) GOTO 1503
  93. SEGDES RI1
  94. GOTO 1501
  95. 1503 CONTINUE
  96. SEGDES RI1
  97. 1502 CONTINUE
  98. SEGDES MRIGID
  99. GOTO 1500
  100. 1501 CONTINUE
  101. SEGDES MRIGID
  102. CALL AJOUN (ITLACC,MRIGID,ILISSE,1)
  103. 1500 CONTINUE
  104. 599 CONTINUE
  105. SEGSUP ILISBB
  106. 600 CONTINUE
  107. * SEGDES ICOLAC,ILISSE
  108. RETURN
  109. END
  110.  
  111.  
  112.  
  113.  
  114.  
  115.  
  116.  
  117.  
  118.  
  119.  
  120.  
  121.  
  122.  
  123.  

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