Télécharger redu.eso

Retour à la liste

Numérotation des lignes :

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

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