Télécharger manuc5.eso

Retour à la liste

Numérotation des lignes :

  1. C MANUC5 SOURCE FANDEUR 16/12/05 21:39:59 9211
  2.  
  3. *--------------------------------------------------------------------*
  4. * *
  5. * CREATION D'UN NOUVEAU CHAMELEM PAR MANU *
  6. * *
  7. *--------------------------------------------------------------------*
  8. SUBROUTINE MANUC5
  9.  
  10. IMPLICIT INTEGER(I-N)
  11. IMPLICIT REAL*8(A-H,O-Z)
  12. -INC CCOPTIO
  13.  
  14. -INC SMLMOTS
  15. -INC SMLREEL
  16. -INC SMLENTI
  17. -INC SMELEME
  18. -INC SMMODEL
  19. *
  20. CHARACTER*4 MOCHOI,MOTYPE(3)
  21. CHARACTER*8 MOCHOY
  22. CHARACTER*8 CAR
  23. CHARACTER*16 JECONS
  24. CHARACTER*72 JEROME
  25. CHARACTER*8 LISMOT(5),REPA(1)
  26. DATA MOTYPE/'TYPE','CONS','EVOL'/
  27. DATA REPA/'REPA'/
  28. DATA LISMOT/'NOEUD','GRAVITE','RIGIDITE','MASSE','STRESSES'/
  29. *
  30. * Initialisation des segments
  31. *
  32. IPMODL=0
  33. IPMAIL=0
  34. IPLAC =0
  35. *
  36. * LECTURE D'UN MODELE
  37. *
  38. CALL LIROBJ('MMODEL',IPMODL,0,IRET)
  39. IF (IERR.NE.0) RETURN
  40. IF (IRET.EQ.0) THEN
  41. *
  42. * SINON D'UN MAILLAGE
  43. *
  44. MOTERR(1:8)='MAILLAGE'
  45. CALL MESLIR(-137)
  46. CALL LIROBJ('MAILLAGE',IPMAIL,0,IRET)
  47. IF (IERR.NE.0) RETURN
  48. *
  49. * SINON lecture du mot EVOL
  50. *
  51. IF (IRET.EQ.0) THEN
  52. CALL LIRMOT(MOTYPE(3),1,IPLAC,0)
  53. IF (IERR.NE.0) RETURN
  54. IF (IPLAC.NE.1) THEN
  55. CALL ERREUR(907)
  56. RETURN
  57. ENDIF
  58. IF (IPLAC.EQ.1) THEN
  59. CALL MANUC8
  60. RETURN
  61. ENDIF
  62. ENDIF
  63. ENDIF
  64. *
  65. JG=0
  66. JGN=4
  67. JGM=0
  68. SEGINI,MLMOTS
  69. SEGINI,MLMOT1
  70. SEGINI,MLMOT2
  71. SEGINI,MLMOT3
  72. SEGINI,MLREE1
  73. SEGINI,MLENT2
  74.  
  75. L1 = 0
  76. LL1 = 0
  77. IPLAC = 0
  78. *
  79. itart=0
  80. CALL LIRMOT(REPA,1,itart,0)
  81. IF (IERR.NE.0) GOTO 99
  82. *
  83. 10 CONTINUE
  84. *
  85. * ON DESIRE LIRE UNE COMPOSANTE
  86. *
  87. IRCHOI = 0
  88. CALL LIRCHA(MOCHOY,0,IRCHOI)
  89. IF (IERR.NE.0) GOTO 99
  90. IF (IRCHOI.EQ.0) GO TO 20
  91. MOCHOI=MOCHOY(1:4)
  92. *
  93. * SI ON A LU LE MOT TYPE
  94. *
  95. IF (MOCHOI.EQ.MOTYPE(1)) THEN
  96. CALL LIRCHA(JEROME,1,L1)
  97. GOTO 10
  98. ENDIF
  99. *
  100. * SI ON A LU LE MOT CONS
  101. *
  102. IF(IPMAIL.NE.0)THEN
  103. IF(MOCHOI.EQ.MOTYPE(2)) THEN
  104. CALL LIRCHA(JECONS,1,LL1)
  105. GO TO 10
  106. ENDIF
  107. ENDIF
  108. IF(IPMODL.NE.0.AND.IPLAC.EQ.0)THEN
  109. CALL PLACE(LISMOT,5,IPLAC,MOCHOY)
  110. IF (IPLAC.NE.0)GOTO 10
  111. ENDIF
  112. *
  113. * SINON ON TESTE LE NOMBRE DE CARACTERES LUS
  114. *
  115. IF(IRCHOI.GT.4) THEN
  116. CALL ERREUR(536)
  117. GOTO 99
  118. ENDIF
  119. *
  120. CALL LIRREE(RECOM,0,IRET2)
  121. IF (IRET2.EQ.1) THEN
  122. MLMOT1.MOTS(**) = MOCHOI
  123. JG=MLREE1.PROG(/1)+1
  124. SEGADJ MLREE1
  125. MLREE1.PROG(JG)=RECOM
  126. ELSE
  127. CALL QUETYP(CAR,0,IRET1)
  128. IF (IERR.NE.0) GO TO 99
  129. CALL LIROBJ(CAR,IPTRUC,0,IRET1)
  130. IF (IERR.NE.0) GO TO 99
  131. *
  132. * ON A LU UN OBJET DE TYPE AUTRE QU'UN FLOTTANT
  133. *
  134. MLMOT2.MOTS(**) = MOCHOI
  135. MLMOT3.MOTS(**)=CAR(1:4)
  136. MOTS(**) =CAR(5:8)
  137. JG=MLENT2.LECT(/1)+1
  138. SEGADJ MLENT2
  139. MLENT2.LECT(JG)=IPTRUC
  140. ENDIF
  141. GOTO 10
  142. *
  143. 20 CONTINUE
  144.  
  145. IPOI1 = 0
  146. IF ( L1.EQ.0) THEN
  147. JEROME=' '
  148. L1 = 1
  149. ENDIF
  150. *
  151. * RECUPERATION DES ZONES ELEMENTAIRES DU MAILLAGE
  152. *
  153. IF(IPMAIL.NE.0)THEN
  154. MELEME=IPMAIL
  155. SEGACT MELEME
  156. JG=LISOUS(/1)
  157. IF (JG.EQ.0) THEN
  158. JG=1
  159. SEGINI MLENT1
  160. MLENT1.LECT(1)=IPMAIL
  161. ELSE
  162. SEGINI MLENT1
  163. DO 22 I =1,JG
  164. MLENT1.LECT(I)=LISOUS(I)
  165. 22 CONTINUE
  166. ENDIF
  167. SEGDES MELEME
  168. *
  169. IF ( LL1.EQ.0) THEN
  170. JECONS=' '
  171. ENDIF
  172. *
  173. * ON STOCKE LE NOM DU COMPOSANT
  174. JGN=16
  175. JGM=JG
  176. SEGINI MLMOT4
  177. DO 23 I=1,JG
  178. MLMOT4.MOTS(I)=JECONS
  179. 23 CONTINUE
  180. *
  181. CALL MANUC4(MLENT1,MLMOT1,MLMOT2,MLMOT3,MLMOTS,MLREE1,
  182. & MLENT2,JEROME,L1,MLMOT4,IPOI1)
  183. *
  184. * Suppression des segments
  185. *
  186. SEGSUP,MLENT1
  187. SEGSUP,MLMOT4
  188.  
  189. ELSE
  190. IF(IPLAC.EQ.0)IPLAC=1
  191. MMODEL=IPMODL
  192. SEGACT,MMODEL
  193. N1 = KMODEL(/1)
  194. DO 69 I=1,N1
  195. IMODEL=KMODEL(I)
  196. SEGACT,IMODEL
  197. 69 CONTINUE
  198. CALL MANUC6(IPMODL,MLMOT1,MLMOT2,MLMOT3,MLMOTS,MLREE1,
  199. & MLENT2,JEROME,L1,IPLAC,IPOI1,itart)
  200. DO 68 I=1,N1
  201. IMODEL=KMODEL(I)
  202. SEGDES,IMODEL
  203. 68 CONTINUE
  204. SEGDES,MMODEL
  205. ENDIF
  206.  
  207. IF (IERR.NE.0) GOTO 99
  208.  
  209. * Ecriture du CHAMP resultat :
  210. CALL ECROBJ('MCHAML ',IPOI1)
  211. *
  212. * Suppression des segments
  213. *
  214. 99 CONTINUE
  215. SEGSUP,MLMOTS
  216. SEGSUP,MLMOT1
  217. SEGSUP,MLMOT2
  218. SEGSUP,MLMOT3
  219. SEGSUP,MLREE1
  220. SEGSUP,MLENT2
  221.  
  222. RETURN
  223. END
  224.  
  225.  
  226.  

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