Télécharger redu.eso

Retour à la liste

Numérotation des lignes :

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

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