Télécharger redu.eso

Retour à la liste

Numérotation des lignes :

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

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