Télécharger kqcest.eso

Retour à la liste

Numérotation des lignes :

  1. C KQCEST SOURCE BP208322 16/11/18 21:18:20 9177
  2. SUBROUTINE KQCEST(MAIL,IKR)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C*************************************************************************
  6. C Ce SP regarde la famille d'éléments
  7. C
  8. C IKT = 0 Ce n'était pas des QCF
  9. C IKT = 1 C'était des QCF
  10. C IKL = 0 Ce n'était pas des Lineaires
  11. C IKL = 1 C'était des Lineaires
  12. C IKR = 0 Famille non reconnue
  13. C IKR = 1 C'était des QCF
  14. C IKR = 2 C'était des Lineaires
  15. C IKR = 3 C'était des Macro
  16. C IKR = 4 C'était des quadratiques castem 2000 (mecanique)
  17. C IKR =34 C'était des Macro ou des Quad
  18. C IKR =134 C'était des Macro ou des Quad ou des quaf
  19. C IKR =1341 C'était des Macro ou des Quad ou des quaf SEG3
  20. C IKR =13 C'était des Macro ou des Quaf
  21. C
  22. C*************************************************************************
  23. -INC CCOPTIO
  24. -INC SMCOORD
  25. -INC CCGEOME
  26. -INC SMELEME
  27. PARAMETER (NBTE=28)
  28. CHARACTER*8 NOM8,LTYPL(NBTE)
  29.  
  30. DATA LTYPL/
  31. & 'SEG3 ','TRI7 ','QUA9 ',
  32. & 'CU27 ','PR21 ','TE15 ','PY19 ',
  33. & 'SEG2 ','TRI3 ','QUA4 ',
  34. & 'CUB8 ','PRI6 ','TET4 ','PYR5 ',
  35. & 'SEG3 ','TRI6 ','QUA9 ',
  36. & 'CU27 ','PR18 ','TE10 ','PY14 ',
  37. & 'SEG3 ','TRI6 ','QUA8 ',
  38. & 'CU20 ','PR15 ','TE10 ','PY13 '/
  39.  
  40.  
  41.  
  42. C****
  43. MELEME=MAIL
  44. IKR=0
  45. SEGACT MELEME
  46. NBSOUS=LISOUS(/1)
  47. C On regarde à qui on a à faire
  48. C SONT ce des QCF IKT=1 ?
  49. IKKT=1
  50. IKKL=1
  51. IKKM=1
  52. IKKQ=1
  53. NBSOU1=NBSOUS
  54. IF(NBSOU1.EQ.0)NBSOU1=1
  55. DO 1670 L=1,NBSOU1
  56. IPT1=MELEME
  57. IF(NBSOU1.NE.1)IPT1=LISOUS(L)
  58. SEGACT IPT1
  59. NOM8=NOMS(IPT1.ITYPEL)//' '
  60. CALL OPTLI(IP,LTYPL,NOM8,NBTE)
  61. IF(IP.EQ.0)THEN
  62. IKR=0
  63. RETURN
  64. ENDIF
  65. IF(NOM8.EQ.'SEG3'.AND.NBSOU1.EQ.1)THEN
  66. IKR =1341
  67. RETURN
  68. ENDIF
  69. IF(IP.GT.7)IKKT=0
  70. CALL OPTLI(IP,LTYPL(8),NOM8,7)
  71. IF(IP.EQ.0)IKKL=0
  72. CALL OPTLI(IP,LTYPL(15),NOM8,7)
  73. IF(IP.EQ.0)IKKM=0
  74. CALL OPTLI(IP,LTYPL(22),NOM8,7)
  75. IF(IP.EQ.0)IKKQ=0
  76. SEGDES IPT1
  77. 1670 CONTINUE
  78.  
  79. C write(6,*)'IKKT,IKKL,IKKM,IKKQ=',IKKT,IKKL,IKKM,IKKQ
  80. IF(IKKT.NE.0)IKR=1
  81. IF(IKKL.NE.0)IKR=2
  82. IF(IKKM.NE.0)IKR=3
  83. IF(IKKQ.NE.0)IKR=4
  84. IF(IKKM.EQ.1.AND.IKKQ.EQ.1)IKR=34
  85. IF(IKKT.EQ.1.AND.IKKM.EQ.1.AND.IKKQ.EQ.1)IKR=134
  86. IF(IKKT.EQ.1.AND.IKKM.EQ.1)IKR=13
  87.  
  88. RETURN
  89. 1001 FORMAT(20(1X,I5))
  90. END
  91.  
  92.  
  93.  
  94.  
  95.  
  96.  
  97.  
  98.  
  99.  

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