Télécharger manuc5.eso

Retour à la liste

Numérotation des lignes :

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

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