Télécharger hatstr.eso

Retour à la liste

Numérotation des lignes :

  1. C HATSTR SOURCE PV 17/12/05 21:16:26 9646
  2. SUBROUTINE HATSTR (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 SOSTU
  8. C DEJA CONTENUS DANS LES PILES
  9. C LOGIQUE:
  10. C ON SE POINTE SUR LA PILE 9 DES STRUCT
  11. C ON CREE LA TABLE DES OBJETS DU TYPE DE CETTE PILE
  12. C ON TESTE SI LE POINTEUR DE L OBJET EST DANS LA PILE
  13. C SI OUI, ON PASSE A L OBJET SUIVANT.
  14. C SI NON
  15. C SI L ENSEMBLE DES POINTEURS SOSTU EST CONTENU DANS LA PILE 12
  16. C ALORS ON RAJOUTE L OBJET DANS LA PILE 9, CE QUI OBLIGE A UN
  17. C RAPPEL DE FILLPI
  18. C
  19. C PROGRAMME PAR : FARVACQUE-REPRIS PAR LENA
  20. C APPELE PAR : SAUV
  21. C APPELLE : SORT7 SORT8 ERREUR REPERT
  22. C
  23. C=======================================================================
  24. C TABLEAU KCOLA :
  25. C 1 MELEME 2 CHPOIN 3 MRIGID 4 MCHAFF 5 MCHELM 6 MCLSTR
  26. C 7 MELSTR 8 MSOLUT 9 MSTRUC 10 MTABLE 11 MAFFEC 12 MSOSTU
  27. C 13 IMATRI 14 MJONCT 15 MATTAC 16 MMATRI 17 MDEFOR 18 MLREEL
  28. C 19 MLENTI 20 MCHARG 21 MODELE 22 MEVOLL
  29. C=======================================================================
  30. C
  31. -INC SMSTRUC
  32.  
  33. -INC PPARAM
  34. -INC CCOPTIO
  35. -INC TMCOLAC
  36. SEGMENT ILISBB
  37. INTEGER ILISOB(MLON)
  38. ENDSEGMENT
  39. DIMENSION IBID(1)
  40. C
  41. CHARACTER*(8) ITYPE
  42. C
  43. SEGACT ICOLAC
  44. ILISSE=ILISSG
  45. SEGACT ILISSE*MOD
  46. C
  47. C
  48. C **************************** MSTRUC ET MSOSTU*********************
  49. C-----ON SE POINTE SUR LA PILE DES SOSTU
  50. ITLAC1=KCOLA(12)
  51. IMAX1=ITLAC1.ITLAC(/1)
  52. IF(IMAX1.EQ.0) GO TO 598
  53. C
  54. C LA PILE DES SOSTU N EST PAS VIDE-------------------------------
  55. ITYPE='STRUCTUR'
  56. IFILE=0
  57. CALL TYPFIL (ITYPE,IFILE)
  58. IF (IFILE.LE.0) GO TO 598
  59. ITLACC=KCOLA(IFILE)
  60. CALL LISTOB(ITYPE,MLON,IBID,0)
  61. SEGINI ILISBB
  62. CALL LISTOB(ITYPE,N,ILISOB,1)
  63. C CALL REPERT (ITYPE,N)
  64. IF (N.EQ.0) GO TO 599
  65. C
  66. DO 1500 I =1,N
  67. MSTRUC=ILISOB(I)
  68. C CALL LIROBJ(ITYPE,MSTRUC,1,IRETOU)
  69. IF(IERR.EQ.0) RETURN
  70. CALL SNOM2(MSTRUC,ITLACC,IRET)
  71. IF(IRET.NE.0) GOTO 1500
  72. SEGACT MSTRUC
  73. NSOU=LISTRU(/1)
  74. CALL SORT8(LISTRU,NSOU,ITLAC1.ITLAC,IMAX1,IRET)
  75. SEGDES MSTRUC
  76. IF(IRET.EQ.1) GOTO 1500
  77. CALL AJOUN (ITLACC,MSTRUC,ILISSE,1)
  78. 1500 CONTINUE
  79. 599 CONTINUE
  80. SEGSUP ILISBB
  81. 598 CONTINUE
  82. * SEGDES ICOLAC,ILISSE
  83. RETURN
  84. END
  85.  
  86.  
  87.  
  88.  
  89.  
  90.  
  91.  
  92.  
  93.  
  94.  
  95.  
  96.  

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