Télécharger la plaquette Cast3M


fr en

Télécharger hatrig.eso

Retour à la liste

Numérotation des lignes : 

hatrig

  1. C HATRIG    SOURCE    PV        17/12/05    21:16:25     9646           
  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.  
  36. -INC PPARAM
  37. -INC CCOPTIO
  38. -INC TMCOLAC
  39.       SEGMENT ILISBB
  40.          INTEGER ILISOB(MLON)
  41.       ENDSEGMENT
  42.       DIMENSION IBID(1)
  43. C
  44.       CHARACTER*(8) ITYPE
  45. C
  46.       SEGACT ICOLAC
  47.       ILISSE=ILISSG
  48.       SEGACT ILISSE*MOD
  49. C
  50. C
  51. C     **************************** MRIGID ******************************
  52. C
  53.       IFILE=0
  54.       ITYPE='RIGIDITE'
  55.       CALL TYPFIL (ITYPE,IFILE)
  56.       ITLACC=KCOLA(IFILE)
  57.       IMAX1=ITLAC(/1)
  58.       IF(IMAX1.EQ.0) GO TO 600
  59.       CALL LISTOB(ITYPE,MLON,IBID,0)
  60.       SEGINI ILISBB
  61.       CALL LISTOB(ITYPE,N,ILISOB,1)
  62. C     LA PILE N EST PAS VIDE-------------------------------
  63. C      CALL REPERT (ITYPE,N)
  64.       IF (N.EQ.0) GO TO 599
  65.       ITLAC1=KCOLA(1)
  66.       ITLAC2=KCOLA(11)
  67.       ITLAC3=KCOLA(13)
  68. C
  69.       DO 1500 I   =1,N
  70.       MRIGID = ILISOB(I)
  71. C      CALL LIROBJ(ITYPE,MRIGID,1,IRETOU)
  72.       CALL SNOM2(MRIGID,ITLACC,IRET)
  73.       IF(IRET.NE.0) GOTO 1500
  74. C --- ON RECHERCHE PLUS PROFONDEMENT
  75.       SEGACT MRIGID
  76.       NRIGEL=IRIGEL(/2)
  77.       DO 1501 IR=1,NRIGEL
  78.       DO 1502 J=1,IMAX1
  79.       RI1=ITLAC(J)
  80.       if(ri1.eq.0) goto 1502
  81.       SEGACT RI1
  82.       NRIGE1=RI1.IRIGEL(/2)
  83.       DO 1503 K=1,NRIGE1
  84. C     KK=ITLAC1.ITLAC(RI1.IRIGEL(1,K))
  85. C     IF(IRIGEL(1,IR).NE.KK) GOTO 1503
  86. C     IF(RI1.IRIGEL(2,K).EQ.0) THEN
  87. C         KK=0
  88. C       ELSE
  89. C         KK=ITLAC2.ITLAC(RI1.IRIGEL(2,K))
  90. C     ENDIF
  91. C     IF(IRIGEL(2,IR).NE.KK) GOTO 1503
  92. C     KK=ITLAC3.ITLAC(RI1.IRIGEL(4,K))
  93. C     IF(IRIGEL(4,IR).NE.KK) GOTO 1503
  94.       IF(IRIGEL(4,IR).NE.RI1.IRIGEL(4,K)) GOTO 1503
  95.       SEGDES RI1
  96.       GOTO 1501
  97.  1503 CONTINUE
  98.       SEGDES RI1
  99.  1502 CONTINUE
  100.       SEGDES MRIGID
  101.       GOTO 1500
  102.  1501 CONTINUE
  103.       SEGDES MRIGID
  104.       CALL AJOUN (ITLACC,MRIGID,ILISSE,1)
  105.  1500 CONTINUE
  106.   599 CONTINUE
  107.       SEGSUP ILISBB
  108.   600 CONTINUE
  109. *      SEGDES ICOLAC,ILISSE
  110.       RETURN
  111.       END
  112.  
  113.  
  114.  
  115.  
  116.  
  117.  
  118.  
  119.  
  120.  
  121.  
  122.  
  123.  
  124.  
  125.  
  126.  

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