Télécharger manuc5.eso

Retour à la liste

Numérotation des lignes :

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

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