Télécharger redu.eso

Retour à la liste

Numérotation des lignes :

  1. C REDU SOURCE GF238795 18/02/08 21:15:17 9742
  2. SUBROUTINE REDU
  3. C_______________________________________________________________________
  4. C
  5. C sous routine de l'operateur redu qui aiguille suivant la fonctionnalite
  6. C
  7. C_______________________________________________________________________
  8. C
  9. C declaration
  10. C
  11. IMPLICIT REAL*8(A-H,O-Z)
  12. IMPLICIT INTEGER(I-N)
  13. -INC CCOPTIO
  14. -INC SMELEME
  15. -INC SMNUAGE
  16. -INC SMLMOTS
  17. -INC SMTABLE
  18. -INC SMCHAML
  19. -INC SMMODEL
  20. C
  21. INTEGER I,NCOMP,J,IPO,INUA
  22. CHARACTER*4 IMO,charre
  23. LOGICAL logr1
  24. CHARACTER*8 TYPOBJ
  25. character*4 mostri(1)
  26. data mostri/'STRI'/
  27. CALL OOONTH(ITH)
  28. C
  29. C executable
  30. C
  31. C
  32. C a-t'on en entrée une table esclave si oui on fusionne
  33. C
  34. C a-t'on le mot strict?
  35. istric=0
  36. call lirmot(mostri,1,istric,0)
  37. C
  38. call lirtab('ESCLAVE',mtable,0,iretou)
  39. if(iretou.ne. 0) then
  40. C write(6,*) ' on fusionne la table esclave'
  41. typobj=' '
  42. segact mtable
  43. ml=mlotab
  44. ind=mtabii(3)
  45. call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,typobj,ivalre,
  46. > xvalre,charre,logr1,id1)
  47. if (ierr.ne.0) return
  48. C if (typobj.eq.'CHPOINT'.or.typobj.eq.'MCHAML')then
  49. if (typobj.eq.'MCHAML')then
  50. do i=4,ml
  51. segact mtable
  52. ind=mtabii(i)
  53. call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,
  54. & typobj,ivalre,xvalre,charre,logr1,id2)
  55. if (ierr.ne.0) return
  56. C if (typobj.eq.'CHPOINT') call fuchpo(id1,id2,iretou)
  57. if (typobj.eq.'MCHAML') call fuschl(id1,id2,iretou)
  58. id1=iretou
  59. enddo
  60. else
  61. C write (6,*) ' type ',typobj,' inconnu dans redu '
  62. C call trbac
  63. MOTERR(1:8)='PARA '
  64. call erreur(803)
  65. return
  66. endif
  67. CALL ECROBJ(typobj,id1)
  68. C write(6,*)' on a crée un objet ' , typobj
  69. endif
  70.  
  71. C
  72. C reduction d'une rigidite sur un maillage
  73. C
  74. CALL LIROBJ('RIGIDITE',IPrigi,0,IRETOU)
  75. IF(IRETOU.EQ.0) GOTO 10
  76. CALL LIROBJ('MAILLAGE',IMEL,1,IRETOU)
  77. IF(IRETOU.EQ.0) return
  78. call reduri(iprigi,imel,irig1)
  79. if(irig1.eq.0) return
  80. call ecrobj('RIGIDITE', irig1)
  81. return
  82. 10 CONTINUE
  83. C
  84. C redu d'un chpoint sur (meleme ou point)
  85. C
  86. CALL LIROBJ('CHPOINT ',ICHP,0,IRETOU)
  87. IF(IRETOU.EQ.0) GO TO 1
  88. CALL LIROBJ('MAILLAGE',IMEL,0,IRETOU)
  89. IF(IRETOU.EQ.0) THEN
  90. CALL LIROBJ('POINT',IP1,0,IRETOU)
  91. IF (IRETOU.NE.0) THEN
  92. NBNN=1
  93. NBELEM=1
  94. NBREF=0
  95. NBSOUS=0
  96. SEGINI MELEME
  97. ITYPEL=1
  98. NUM(1,1)=IP1
  99. SEGDES MELEME
  100. IMEL=MELEME
  101. ELSE
  102. CALL REFUS
  103. GO TO 1
  104. ENDIF
  105. ENDIF
  106. CALL REDUIR(ICHP,IMEL,IRET)
  107. IF ( IERR .NE. 0) RETURN
  108. CALL ECROBJ('CHPOINT',IRET)
  109. RETURN
  110. C
  111. 1 CONTINUE
  112.  
  113. C
  114. C redu mchaml sur meleme (ou point)
  115. C
  116. CALL LIROBJ('MCHAML',ICHE,0,IRETOU)
  117. IF(IRETOU.EQ.0) GOTO 2
  118. CALL LIROBJ('MAILLAGE',IMEL,0,IRETOU)
  119. IF(IRETOU.EQ.0) THEN
  120. CALL LIROBJ('POINT',IP1,0,IRETOU)
  121. IF (IRETOU.NE.0) THEN
  122. NBNN=1
  123. NBELEM=1
  124. NBREF=0
  125. NBSOUS=0
  126. SEGINI MELEME
  127. ITYPEL=1
  128. NUM(1,1)=IP1
  129. SEGDES MELEME
  130. IMEL=MELEME
  131. ELSE
  132. CALL REFUS
  133. GOTO 2
  134. ENDIF
  135. ENDIF
  136. CALL REDUIC(ICHE,IMEL,IRET)
  137. IF ( IERR .NE. 0) RETURN
  138. CALL ECROBJ('MCHAML',IRET)
  139. RETURN
  140. C
  141. 2 CONTINUE
  142.  
  143. C
  144. C redu chamelem sur mmodel
  145. C
  146. CALL LIROBJ('MCHAML',ICHE,0,IRETOU)
  147. IF(IRETOU.EQ.0) GOTO 3
  148. CALL LIROBJ('MMODEL',IPMODL,0,IRETOU)
  149. IF (IRETOU.EQ.0) THEN
  150. CALL REFUS
  151. GO TO 3
  152. ENDIF
  153. CALL REDUAF(ICHE,IPMODL,IPCHM,ISTRIC,IRET,KERRE)
  154. IF ( IRET .NE. 1) THEN
  155. CALL ERREUR(KERRE)
  156. RETURN
  157. ENDIF
  158. C segdes de l'entree
  159. mchelm=iche
  160. segact mchelm
  161. do j=1,ichaml(/1)
  162. mchaml=ichaml(j)
  163. segact mchaml
  164. do k=1,ielval(/1)
  165. melval=ielval(k)
  166. ** segdes melval
  167. enddo
  168. segdes mchaml
  169. enddo
  170. segdes mchelm
  171. mmodel = IPMODL
  172. do i = 1, kmodel(/1)
  173. imodel = kmodel(i)
  174. SEGDES,imodel
  175. enddo
  176. SEGDES,mmodel
  177. C segdes du resultat
  178. mchelm=ipchm
  179. segact mchelm
  180. do j=1,ichaml(/1)
  181. mchaml=ichaml(j)
  182. segact mchaml
  183. do k=1,ielval(/1)
  184. melval=ielval(k)
  185. c if (ith.eq.0) segdes melval
  186. segdes melval
  187. enddo
  188. segdes mchaml
  189. enddo
  190. segdes mchelm
  191. C
  192. CALL ECROBJ('MCHAML',IPCHM)
  193. RETURN
  194. C
  195. 3 CONTINUE
  196. C
  197. C redu chpoint sur masq
  198. C
  199. CALL LIROBJ('CHPOINT',ICHP,0,IRETOU)
  200. IF(IRETOU.EQ.0) GO TO 4
  201. CALL LIROBJ('CHPOINT',ICHP1,0,IRETOU)
  202. IF(IRETOU.EQ.0) THEN
  203. CALL REFUS
  204. GO TO 4
  205. ENDIF
  206. CALL REDUCP(ICHP,ICHP1,IRET)
  207. IF(IERR.NE.0) RETURN
  208. CALL ECROBJ('CHPOINT',IRET)
  209. RETURN
  210. C
  211. 4 CONTINUE
  212. C
  213. C redu mmodel sur meleme ou point ou reduit le model de contatct
  214. C au element qui peuvent etre actifs
  215. C
  216. CALL LIROBJ('MMODEL',IPMODL,0,IRETOU)
  217. IF(IRETOU.EQ.0) GOTO 5
  218. CALL LIRCHA(charre,0,ireto)
  219. if(ireto.ne.0) then
  220. if( charre.ne.'CONT' ) then
  221. call refus
  222. else
  223. call redcon(ipmodl,iret)
  224. call ecrobj('MMODEL',iret)
  225. return
  226. endif
  227. endif
  228. CALL LIROBJ('MAILLAGE',IMEL,0,IRETOU)
  229. IF(IRETOU.EQ.0) THEN
  230. CALL LIROBJ('POINT',IP1,0,IRETOU)
  231. IF (IRETOU.NE.0) THEN
  232. NBNN=1
  233. NBELEM=1
  234. NBREF=0
  235. NBSOUS=0
  236. SEGINI MELEME
  237. ITYPEL=1
  238. NUM(1,1)=IP1
  239. SEGDES MELEME
  240. IMEL=MELEME
  241. ELSE
  242. CALL REFUS
  243. GOTO 5
  244. ENDIF
  245. ENDIF
  246. CALL REDUMO(IPMODL,IMEL,IRET)
  247. IF (IRET.NE.0) THEN
  248. CALL ECROBJ('MMODEL',IRET)
  249. ENDIF
  250. RETURN
  251. C
  252. 5 CONTINUE
  253. C
  254. C redu d'un nuage a des composantes
  255. C
  256. CALL LIRCHA(IMO,1,IRETOU)
  257. IF (IRETOU.NE.0) THEN
  258. JGN = 4
  259. JGM = 10
  260. SEGINI MLMOTS
  261. MOTS(1) = IMO
  262. IPO1 = MLMOTS
  263. ENDIF
  264. DO 100 I = 2,100
  265. CALL LIRCHA(IMO,0,IRETOU)
  266. IF (IRETOU.NE.0) THEN
  267. MOTS(I) = IMO
  268. IF (I.GT.10) THEN
  269. JGM = I
  270. SEGADJ MLMOTS
  271. MOTS(I) = IMO
  272. IPO1 = MLMOTS
  273. ENDIF
  274. NCOMP = I
  275. ELSE
  276. NCOMP = I - 1
  277. GOTO 101
  278. ENDIF
  279. 100 CONTINUE
  280. 101 CONTINUE
  281. DO 200 I = 1,NCOMP
  282. DO 201 J = (I + 1),NCOMP
  283. IF (MOTS(I).EQ.MOTS(J)) THEN
  284. CALL ERREUR(674)
  285. RETURN
  286. ENDIF
  287. 201 CONTINUE
  288. 200 CONTINUE
  289. CALL LIROBJ('NUAGE',INUA,1,IRETOU)
  290. MNUAG1 = INUA
  291. IF (IRETOU.EQ.0) GOTO 6
  292. CALL REDNUA(INUA,IPO1,NCOMP,INUAR,IRET)
  293. IF (IRET.NE.0) THEN
  294. CALL ECROBJ('NUAGE',INUAR)
  295. ENDIF
  296. SEGDES MLMOTS
  297. RETURN
  298. C
  299. 6 CONTINUE
  300.  
  301. c
  302. c pas d operande correcte trouve
  303. c
  304. CALL QUETYP(MOTERR(1:8),0,IRETOU)
  305. IF(IRETOU .NE. 0) THEN
  306. CALL ERREUR (39)
  307. ELSE
  308. CALL ERREUR(533)
  309. ENDIF
  310.  
  311. RETURN
  312. END
  313.  
  314.  
  315.  
  316.  
  317.  
  318.  
  319.  
  320.  
  321.  

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