Télécharger hatstr.eso

Retour à la liste

Numérotation des lignes :

  1. C HATSTR SOURCE PV 16/11/26 21:15:56 9205
  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. -INC CCOPTIO
  33. -INC TMCOLAC
  34. SEGMENT ILISBB
  35. INTEGER ILISOB(MLON)
  36. ENDSEGMENT
  37. DIMENSION IBID(1)
  38. C
  39. CHARACTER*(8) ITYPE
  40. C
  41. SEGACT ICOLAC
  42. ILISSE=ILISSG
  43. SEGACT ILISSE*MOD
  44. C
  45. C
  46. C **************************** MSTRUC ET MSOSTU*********************
  47. C-----ON SE POINTE SUR LA PILE DES SOSTU
  48. ITLAC1=KCOLA(12)
  49. IMAX1=ITLAC1.ITLAC(/1)
  50. IF(IMAX1.EQ.0) GO TO 598
  51. C
  52. C LA PILE DES SOSTU N EST PAS VIDE-------------------------------
  53. ITYPE='STRUCTUR'
  54. IFILE=0
  55. CALL TYPFIL (ITYPE,IFILE)
  56. IF (IFILE.LE.0) GO TO 598
  57. ITLACC=KCOLA(IFILE)
  58. CALL LISTOB(ITYPE,MLON,IBID,0)
  59. SEGINI ILISBB
  60. CALL LISTOB(ITYPE,N,ILISOB,1)
  61. C CALL REPERT (ITYPE,N)
  62. IF (N.EQ.0) GO TO 599
  63. C
  64. DO 1500 I =1,N
  65. MSTRUC=ILISOB(I)
  66. C CALL LIROBJ(ITYPE,MSTRUC,1,IRETOU)
  67. IF(IERR.EQ.0) RETURN
  68. CALL SNOM2(MSTRUC,ITLACC,IRET)
  69. IF(IRET.NE.0) GOTO 1500
  70. SEGACT MSTRUC
  71. NSOU=LISTRU(/1)
  72. CALL SORT8(LISTRU,NSOU,ITLAC1.ITLAC,IMAX1,IRET)
  73. SEGDES MSTRUC
  74. IF(IRET.EQ.1) GOTO 1500
  75. CALL AJOUN (ITLACC,MSTRUC,ILISSE,1)
  76. 1500 CONTINUE
  77. 599 CONTINUE
  78. SEGSUP ILISBB
  79. 598 CONTINUE
  80. * SEGDES ICOLAC,ILISSE
  81. RETURN
  82. END
  83.  
  84.  
  85.  
  86.  
  87.  
  88.  
  89.  
  90.  
  91.  
  92.  
  93.  

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