Télécharger kctrp1.eso

Retour à la liste

Numérotation des lignes :

  1. C KCTRP1 SOURCE BP208322 16/11/18 21:18:04 9177
  2. SUBROUTINE KCTRP1(MTABLE,IPOINT,IKAS)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. -INC CCOPTIO
  6. -INC CCGEOME
  7. -INC SMTABLE
  8. -INC SMCOORD
  9. -INC SMELEME
  10. POINTEUR MELEMI.MELEME
  11. DIMENSION XA(3,64),XL(3,4),XG(3,4)
  12. CHARACTER*8 TYPE,NOME
  13.  
  14. IPOINT=0
  15. TYPE=' '
  16. CALL ACMO(MTABLE,'MACRO',TYPE,MACRO)
  17. TYPE=' '
  18. CALL ACMO(MTABLE,'QUADRATI',TYPE,MQ)
  19. IF(MACRO.EQ.0.AND.MQ.EQ.0)THEN
  20.  
  21. TYPE=' '
  22. CALL ACMO(MTABLE,'CENTRE',TYPE,MELEMC)
  23. IF(MELEMC.EQ.0)THEN
  24. MOTERR(1: 8) = 'DOMAINE.'
  25. MOTERR(9:16) = 'CENTRE '
  26. CALL ERREUR(792)
  27. IPOINT=0
  28. RETURN
  29. ENDIF
  30.  
  31. ELSE
  32. IF(MACRO.NE.0)MELEMI=MACRO
  33. IF(MQ .NE.0)MELEMI=MQ
  34.  
  35. CALL ECROBJ('MAILLAGE',MELEMI)
  36. CALL NBEL
  37. CALL LIRENT(NBELEM,1,IRET)
  38. IF(IRET.EQ.0)RETURN
  39. NBSOUS=0
  40. NBREF=0
  41. NBNN=IDIM+1
  42. SEGINI MELEME
  43. IF(IDIM.EQ.2)ITYPEL=4
  44. IF(IDIM.EQ.3)ITYPEL=23
  45. NBV0=XCOOR(/1)/(IDIM+1)
  46. NBPTS=NBV0+(NBELEM*(IDIM+1))
  47. SEGADJ MCOORD
  48. K0=NBV0
  49. KE=0
  50.  
  51.  
  52. SEGACT MELEMI
  53. NBSOUL=MELEMI.LISOUS(/1)
  54. IF(NBSOUL.EQ.0)NBSOUL=1
  55.  
  56. DO 1 L=1,NBSOUL
  57. IPT1=MELEMI
  58. IF(NBSOUL.NE.1)IPT1=MELEMI.LISOUS(L)
  59. SEGACT IPT1
  60. NP=IPT1.NUM(/1)
  61. NEL=IPT1.NUM(/2)
  62.  
  63. NOME=NOMS(IPT1.ITYPEL)//' '
  64. CALL KXL(NOME,'P1',XL)
  65.  
  66. DO 2 K=1,NEL
  67. KE=KE+1
  68. DO 3 M=1,IDIM
  69. DO 3 I=1,NP
  70. NI=IPT1.NUM(I,K)
  71. XA(M,I)=XCOOR((NI-1)*(IDIM+1) +M)
  72. 3 CONTINUE
  73.  
  74. CALL FFQ(NOME,XA,XL,XG,IDIM,NBNN)
  75.  
  76. DO 5 MI=1,NBNN
  77. K0=K0+1
  78. DO 4 M=1,IDIM
  79. XCOOR((K0-1)*(IDIM+1) +M)=XG(M,MI)
  80. 4 CONTINUE
  81. NUM(MI,KE)=K0
  82. 5 CONTINUE
  83. 2 CONTINUE
  84. 1 CONTINUE
  85.  
  86. CALL ECMO(MTABLE,'ELTP1NC ','MAILLAGE',MELEME)
  87. CALL ECRCHA('POI1')
  88. CALL ECROBJ('MAILLAGE',MELEME)
  89. CALL PRCHAN
  90. CALL LIROBJ('MAILLAGE',MELEM1,1,IRET)
  91. CALL ECMO(MTABLE,'CENTREP1','MAILLAGE',MELEM1)
  92. ENDIF
  93.  
  94. IF(IKAS.EQ.1)IPOINT=MELEM1
  95. IF(IKAS.EQ.2)IPOINT=MELEME
  96.  
  97. RETURN
  98. 1002 FORMAT(10(1X,1PE11.4))
  99. END
  100.  
  101.  
  102.  
  103.  
  104.  
  105.  
  106.  
  107.  
  108.  

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