Télécharger la plaquette Cast3M


fr en

Télécharger kqcest.eso

Retour à la liste

Numérotation des lignes : 

kqcest

  1. C KQCEST    SOURCE    CB215821  19/08/20    21:18:56     10287          
  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.  
  24. -INC PPARAM
  25. -INC CCOPTIO
  26. -INC SMCOORD
  27. -INC CCGEOME
  28. -INC SMELEME
  29.       PARAMETER (NBTE=28)
  30.       CHARACTER*8 NOM8,LTYPL(NBTE)
  31.  
  32.       DATA LTYPL/
  33.      &  'SEG3    ','TRI7    ','QUA9    ',
  34.      &  'CU27    ','PR21    ','TE15    ','PY19    ',
  35.      &  'SEG2    ','TRI3    ','QUA4    ',
  36.      &  'CUB8    ','PRI6    ','TET4    ','PYR5    ',
  37.      &  'SEG3    ','TRI6    ','QUA9    ',
  38.      &  'CU27    ','PR18    ','TE10    ','PY14    ',
  39.      &  'SEG3    ','TRI6    ','QUA8    ',
  40.      &  'CU20    ','PR15    ','TE10    ','PY13    '/
  41.  
  42.  
  43.  
  44. C****
  45.       MELEME=MAIL
  46.       IKR=0
  47.       SEGACT MELEME
  48.       NBSOUS=LISOUS(/1)
  49. C On regarde à qui on a à faire
  50. C     SONT ce des QCF IKT=1  ?
  51.       IKKT=1
  52.       IKKL=1
  53.       IKKM=1
  54.       IKKQ=1
  55.       NBSOU1=NBSOUS
  56.       IF(NBSOU1.EQ.0)NBSOU1=1
  57.       DO 1670 L=1,NBSOU1
  58.       IPT1=MELEME
  59.       IF(NBSOU1.NE.1)IPT1=LISOUS(L)
  60.       SEGACT IPT1
  61.       NOM8=NOMS(IPT1.ITYPEL)//'    '
  62.       CALL OPTLI(IP,LTYPL,NOM8,NBTE)
  63.       IF(IP.EQ.0)THEN
  64.       IKR=0
  65.       RETURN
  66.       ENDIF
  67.       IF(NOM8.EQ.'SEG3'.AND.NBSOU1.EQ.1)THEN
  68.       IKR =1341
  69.       RETURN
  70.       ENDIF
  71.       IF(IP.GT.7)IKKT=0
  72.       CALL OPTLI(IP,LTYPL(8),NOM8,7)
  73.       IF(IP.EQ.0)IKKL=0
  74.       CALL OPTLI(IP,LTYPL(15),NOM8,7)
  75.       IF(IP.EQ.0)IKKM=0
  76.       CALL OPTLI(IP,LTYPL(22),NOM8,7)
  77.       IF(IP.EQ.0)IKKQ=0
  78.  1670 CONTINUE
  79.  
  80. C     write(6,*)'IKKT,IKKL,IKKM,IKKQ=',IKKT,IKKL,IKKM,IKKQ
  81.       IF(IKKT.NE.0)IKR=1
  82.       IF(IKKL.NE.0)IKR=2
  83.       IF(IKKM.NE.0)IKR=3
  84.       IF(IKKQ.NE.0)IKR=4
  85.       IF(IKKM.EQ.1.AND.IKKQ.EQ.1)IKR=34
  86.       IF(IKKT.EQ.1.AND.IKKM.EQ.1.AND.IKKQ.EQ.1)IKR=134
  87.       IF(IKKT.EQ.1.AND.IKKM.EQ.1)IKR=13
  88.  
  89.  1001 FORMAT(20(1X,I5))
  90.       END
  91.  
  92.  
  93.  

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