Télécharger kpro.eso

Retour à la liste

Numérotation des lignes :

  1. C KPRO SOURCE CHAT 05/01/13 01:05:02 5004
  2. C KRED SOURCE MAGN 93/12/20 22:56:40 1003
  3. SUBROUTINE KPRO
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8 (A-H,O-Z)
  6. C*************************************************************************
  7. C
  8. C Operateur KPRO
  9. C
  10. C OBJET : to project CHAMPOINT
  11. C SYNTAXE : CHR = KPRO CHP GEO ;
  12. C
  13. C CHP : CHPOINT
  14. C CHR : CHPOINT
  15. C GEO : MAILLAGE (SEG2 or SEG3)
  16. C
  17. C CHR is the projection of CHP following the connectivities GEO.
  18. C The value of CHP at point 1 of each element of GEO (if exists)
  19. C is projected to the point 2 of the same element of GEO thus to
  20. C constitute CHR.
  21. C
  22. C*************************************************************************
  23. CHARACTER*8 TYPE
  24.  
  25. -INC CCOPTIO
  26. -INC SMCOORD
  27. -INC SMCHPOI
  28. POINTEUR MCHP.MCHPOI,MSPO.MSOUPO,MVAL.MPOVAL
  29. POINTEUR NCHP.MCHPOI,NSPO.MSOUPO,NVAL.MPOVAL
  30. -INC SMELEME
  31. POINTEUR MGEO.MELEME,MSPG.MELEME,NSPG.MELEME
  32.  
  33. SEGMENT LOCSGM
  34. INTEGER ICHP(NPART)
  35. ENDSEGMENT
  36.  
  37. C***
  38.  
  39. C Reading the CHPOINT
  40.  
  41. TYPE='CHPOINT '
  42. CALL LIROBJ(TYPE,MCHP,0,IRET)
  43. IF(IRET.EQ.0) THEN
  44. WRITE(6,*)'On attend un CHAMPOINT'
  45. RETURN
  46. ENDIF
  47.  
  48. C Reading the MAILLAGE
  49.  
  50. TYPE='MAILLAGE'
  51. CALL LIROBJ(TYPE,MGEO,0,IRET)
  52. IF(IRET.EQ.0) THEN
  53. WRITE(6,*)'On attend un MAILLAGE'
  54. RETURN
  55. ENDIF
  56.  
  57. C Veryfing the MAILLAGE
  58. inoeu = 2
  59. SEGACT MGEO
  60. ITIPO=MGEO.ITYPEL
  61. IF(ITIPO.LT.2.OR.ITIPO.GT.3) THEN
  62. WRITE(6,*)'On attend un MAILLAGE compose de SEG2 ou SEG3'
  63. RETURN
  64. ENDIF
  65. if(itipo.eq.3) inoeu = 3
  66. NELGEO=MGEO.NUM(/2)
  67. NBNN =1
  68. NBSOUS=0
  69. NBREF =0
  70.  
  71. SEGACT MCHP
  72.  
  73. NPART=MCHP.IPCHP(/1)
  74. NAT =MCHP.JATTRI(/1)
  75. SEGINI LOCSGM
  76.  
  77. IPART=0
  78. DO I=1,NPART
  79.  
  80. MSPO=MCHP.IPCHP(I)
  81. SEGACT MSPO
  82.  
  83. MSPG=MSPO.IGEOC
  84. MVAL=MSPO.IPOVAL
  85. SEGACT MSPG,MVAL
  86.  
  87. NC =MVAL.VPOCHA(/2)
  88. NELSPG=MSPG.NUM(/2)
  89. N =NELGEO
  90. NBELEM=NELGEO
  91. SEGINI NSPG,NVAL
  92. NSPG.ITYPEL=1
  93.  
  94. NPUNTO=0
  95. DO J=1,NELGEO
  96. DO K=1,NELSPG
  97. IELGEO=MGEO.NUM(1,J)
  98. IELSPG=MSPG.NUM(1,K)
  99. IF(IELGEO.EQ.IELSPG) THEN
  100. NPUNTO=NPUNTO+1
  101. NSPG.NUM(1,NPUNTO)=MGEO.NUM(inoeu,J)
  102. DO L=1,NC
  103. NVAL.VPOCHA(NPUNTO,L)=MVAL.VPOCHA(K,L)
  104. ENDDO
  105. GO TO 100
  106. ENDIF
  107. ENDDO
  108. 100 CONTINUE
  109. ENDDO
  110.  
  111. IF(NPUNTO.EQ.0) THEN
  112. SEGSUP NSPG,NVAL
  113. SEGDES MSPG,MVAL,MSPO
  114. GO TO 200
  115. ELSEIF(NPUNTO.NE.NBELEM) THEN
  116. NBELEM=NPUNTO
  117. N =NPUNTO
  118. SEGADJ NSPG,NVAL
  119. ENDIF
  120.  
  121. SEGINI NSPO
  122. NSPO.IGEOC =NSPG
  123. NSPO.IPOVAL=NVAL
  124. DO L=1,NC
  125. NSPO.NOCOMP(L)=MSPO.NOCOMP(L)
  126. NSPO.NOHARM(L)=MSPO.NOHARM(L)
  127. ENDDO
  128.  
  129. NSOUPO=1
  130. SEGINI NCHP
  131. NCHP.MTYPOI =MCHP.MTYPOI
  132. NCHP.MOCHDE =MCHP.MOCHDE
  133. NCHP.IFOPOI =MCHP.IFOPOI
  134. NCHP.IPCHP(1)=NSPO
  135. DO L=1,NAT
  136. NCHP.JATTRI(L)=MCHP.JATTRI(L)
  137. ENDDO
  138.  
  139. IPART=IPART+1
  140. ICHP(IPART)=NCHP
  141.  
  142. SEGDES NCHP,NSPO,NSPG,NVAL,MSPG,MVAL,MSPO
  143.  
  144. 200 CONTINUE
  145.  
  146. ENDDO
  147.  
  148. SEGDES MCHP
  149.  
  150. IF(IPART.EQ.0) THEN
  151. WRITE(6,*)'Le CHPOINT e le MAILLAGE n''ont pas de point commun'
  152. SEGSUP LOCSGM
  153. RETURN
  154. ENDIF
  155.  
  156. NCHP=ICHP(1)
  157. CALL ECROBJ('CHPOINT ',NCHP)
  158.  
  159. IF(IPART.GT.1) THEN
  160. DO I=2,IPART
  161. NCHP=ICHP(I)
  162. CALL ECROBJ('CHPOINT ',NCHP)
  163. CALL PRFUSE
  164. ENDDO
  165. ENDIF
  166.  
  167. SEGSUP LOCSGM
  168.  
  169. RETURN
  170. END
  171.  
  172.  
  173.  

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