Télécharger resou.eso

Retour à la liste

Numérotation des lignes :

  1. C RESOU SOURCE CB215821 20/11/25 13:39:04 10792
  2. SUBROUTINE RESOU
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C
  6. C **** CET OPERATEUR SERT A RESOUDRE UN SYSTEME D EQUATIONS LINEAIRES
  7. C **** CHPOINT = RESOU RIGIDITE CHPOINT
  8. C
  9. C
  10. -INC SMRIGID
  11. -INC SMTEXTE
  12.  
  13. -INC PPARAM
  14. -INC CCOPTIO
  15. -INC SMTABLE
  16. -INC SMCHPOI
  17. -INC SMELEME
  18. -INC SMLCHPO
  19. PARAMETER(ZERO=0.D0)
  20. SEGMENT IDEMEM(0)
  21. segment ideme0(idemem(/1),30)
  22. segment ideme1(idemem(/1),30)
  23. segment idnote(0)
  24. C
  25. CHARACTER*4 LISM(9)
  26. CHARACTER*(8) CHARRE1
  27. CHARACTER*72 CHARRE
  28. REAL*8 XVA
  29. LOGICAL ILOG,ILUG,casfimp
  30. DATA LISM/'NOID','NOUN','ENSE','GRAD','CHOL','STAB','ELIM',
  31. >'NOST','SOUC'/
  32. DATA ILOG/.FALSE./
  33. C
  34. C-------------------------------------------------------
  35. c LECTURE ET INITIALISATION
  36.  
  37. c LECTURE DES OPTIONS
  38. XVA=REAL(0.D0)
  39. IOB=0
  40.  
  41. iverif=1
  42. ipt8=0
  43. iunil=0
  44. * le defaut est de faire une passe d'elimination
  45. nelim=30
  46. * experimentalement 2 passes est mieux
  47. nelim=2
  48. IMTVID=0
  49. NOUNIL=0
  50. NOID=0
  51. NOEN=1
  52. IGRADJ = 0
  53. ICHSKI = 0
  54. INSYM = 0
  55. KIKI=0
  56. KSYMET = 0
  57. IPSHPO = 0
  58. ISTAB=0
  59. ISOUCI = 0
  60. 5 CONTINUE
  61. CALL LIRMOT(LISM,9,KIKI,0)
  62. IF (KIKI.EQ.1) NOID=1
  63. IF (KIKI.EQ.2) NOUNIL=1
  64. IF (KIKI.EQ.3) NOEN=0
  65. * IF (KIKI.EQ.4) IGRADJ = 1
  66. * IF (KIKI.EQ.5) ICHSKI = 1
  67. * IF (KIKI.EQ.4.OR.KIKI.EQ.5) KSYMET = 1
  68. IF (KIKI.eQ.6) ISTAB=1
  69. IF (KIKI.eQ.7) then
  70. call lirent(nelim,1,iretou)
  71. nelim=min(30,max(0,nelim))
  72. endif
  73. IF (KIKI.eQ.8) ISTAB=0
  74. IF (KIKI.eQ.9) ISOUCI=1
  75. IF (KIKI.NE.0) GOTO 5
  76. if (noid.eq.1) iverif=0
  77. IF(NUCROU.EQ.0) THEN
  78. ICHSKI=1
  79. ELSEIF(NUCROU.EQ.1) THEN
  80. IGRADJ=1
  81. KSYMET=1
  82. ENDIF
  83. * WRITE(6,*) ' nucrou', nucrou
  84. * IF ( IGRADJ + ICHSKI .EQ. 0 ) ICHSKI = 1
  85.  
  86. c LECTURE DE LA RIGIDITE
  87. CALL LIROBJ('RIGIDITE',IPOIRI,1,IRETOU)
  88. IF(IERR.NE.0) GO TO 5000
  89. IPRIGO=IPOIRI
  90. C
  91. c LECTURE DE LA PRECISION
  92. PREC=REAL(1.D-18)
  93. CALL LIRREE(PREC,0,IRETOU)
  94. IF(IERR.NE.0) GO TO 5000
  95.  
  96. C REMPLISSAGE DU 2ND MEMBRE IDEMEM(**) A PARTIR DE ...
  97. c ... 'CHPOINT'
  98. SEGINI IDEMEM
  99. 1 CONTINUE
  100. CALL LIROBJ('CHPOINT ',ISECO,0,IRETOU)
  101. IF(IRETOU.NE.0) THEN
  102. IDEMEM(**)=ISECO
  103. * write(6,*) ' extension idemem 1 ',idemem(/1)
  104. GO TO 1
  105. ENDIF
  106.  
  107. c ... 'TABLE DE SOUS-TYPE LIAISONS_STATIQUES'
  108. CALL LIRTAB('LIAISONS_STATIQUES',ITBAS,0,IRET)
  109.  
  110. c ... 'LISTCHPO'
  111. CALL LIROBJ('LISTCHPO',ISECO,0,IRETOU)
  112. IF(IRETOU.NE.0) THEN
  113. mlchpo=ISECO
  114. segact mlchpo
  115. n1 = ichpoi(/1)
  116. do iu = 1 , n1
  117. idemem(**) = ichpoi(iu)
  118. * write(6,*) ' extension idemem 2 ',idemem(/1)
  119. enddo
  120. segdes mlchpo
  121. segini mlchpo
  122. ipshpo = mlchpo
  123. ENDIF
  124. IF (IERR.NE.0) RETURN
  125.  
  126. IF (ITBAS.NE.0 .AND. IIMPI.EQ.333) THEN
  127. WRITE(IOIMP,*) 'on a lu la table des conditions aux limites'
  128. ENDIF
  129. if (itbas.ne.0) then
  130. mtab1 = itbas
  131. segact mtab1
  132. ima = mtab1.mlotab - 1
  133. segini idnote
  134. im = 0
  135. segdes mtab1
  136. else
  137. goto 90
  138. endif
  139. * boucle en cas de résolutions successives avec table
  140. 80 continue
  141. im = im + 1
  142. itmod = 0
  143. ichp0 = 0
  144. if (im.gt.ima) then
  145. if (idemem(/1).gt.0) goto 90
  146. * pas de champs de force
  147. call erreur(1)
  148. return
  149. endif
  150. CALL ACCTAB(ITBAS,'ENTIER',IM,0.d0,' ',.true.,IP0,
  151. & 'TABLE',I1,X1,CHARRE,.true.,ITMOD)
  152. if (ierr.ne.0) return
  153. c table itmod trouvee --> on recupere la force
  154. if (itmod.gt.0) then
  155. CALL ACCTAB(ITMOD,'MOT',0,0.d0,'FORCE',.true.,IP0,
  156. & 'CHPOINT',I1,X1,CHARRE,.true.,ICHP0)
  157. if (ierr.ne.0) return
  158. if (ichp0.gt.0) then
  159. idemem(**) = ichp0
  160. * write(6,*) ' extension idemem 3 ',idemem(/1)
  161. idnote(**) = im
  162. else
  163. call erreur(1)
  164. return
  165. endif
  166. c on cree le point repere ici
  167. CALL CREPO1 (ZERO, ZERO, ZERO, IPOIN)
  168. CALL ECCTAB(ITMOD,'MOT',0,0.0D0,'POINT_REPERE',.TRUE.,0,
  169. & 'POINT',0,0.0D0,' ',.TRUE.,IPOIN)
  170. endif
  171. goto 80
  172. IF (IERR.NE.0) RETURN
  173.  
  174. C-------------------------------------------------------
  175. c DEBUT DU TRAVAIL
  176.  
  177. 90 continue
  178. segini ideme0,ideme1
  179. * verification pas de blocage en double
  180. call verlag(ipoiri)
  181. if (ierr.ne.0) return
  182. * y a t il des matrices de relations non unilaterales
  183. ipoir0 = ipoiri
  184. mrigid=ipoiri
  185. C call prrigi(ipoiri,1)
  186. segact mrigid
  187. nrige= irigel(/1)
  188. idepe=0
  189. nbr = irigel(/2)
  190. do 1000 irig = 1,nbr
  191. meleme=irigel(1,irig)
  192. segact meleme
  193. if ((irigel(6,irig).eq.0.or.nounil.eq.1).and.itypel.eq.22)
  194. > idepe=idepe+num(/2)
  195. if (irigel(6,irig).ne.0) iunil=1
  196. if (irigel(7,1).ne.0) insym=1
  197. 1000 continue
  198. ** if(insym.eq.1) nelim=0
  199. * elimination recursive des conditions aux limites
  200. * on la fait en gradient conjugue ou en appel de unilater
  201. nfois=nelim-1
  202. if (igradj.eq.1.or.(iunil.eq.1.and.nounil.eq.0)) nfois=29
  203. lagdua=0
  204. imult=1
  205. icond=idepe
  206. icondi=icond+1
  207. if=0
  208. do ifois=1,nfois
  209. if(imult.ne.0.and.icond.ne.0.and.
  210. > (icondi-icond.gt.0.or.igradj.eq.1)) then
  211. icondi=icond
  212. lagdua=-1
  213. if=if+1
  214. if(ierr.ne.0) return
  215. call resouc(mrigid,mrigic,idemem,ideme0,ideme1,
  216. > nounil,lagdua,icond,imult,if,imtvid,nelim)
  217. ** write(6,*) ' passe ',if,' condition ',icond
  218. if(ierr.ne.0) return
  219. mrigid=mrigic
  220. endif
  221. enddo
  222. * Si on n'a pas reussi a tout eliminer, on fait encore une passe pour creer lagdua
  223. lagdua=0
  224. if (iunil.eq.0.or.nounil.eq.1) then
  225. if (icond.ne.0) then
  226. if=if+1
  227. if(ierr.ne.0) return
  228. call resouc(mrigid,mrigic,idemem,ideme0,ideme1,
  229. > nounil,lagdua,icond,imult,if,imtvid,nelim)
  230. ** write(6,*) ' passe ','finale',' condition ',icond
  231. if(ierr.ne.0) return
  232. mrigid=mrigic
  233. endif
  234. endif
  235. ** write (6,*) 'nombre de passes',if
  236. if (idepe.ne.0) noid = 1
  237. ipoiri=mrigid
  238. * call prrigi(ipoiri,1)
  239. C-------------------------------------------------------
  240.  
  241. *
  242. * Si au moins une des matrices n'est pas symétrique, on passera
  243. * par le solveur non-symétrique LDMT.
  244. *
  245. SEGACT MRIGID*MOD
  246. NRG = IRIGEL(/1)
  247. NBR = IRIGEL(/2)
  248. C ... Ceci peut arriver si par exemple on extrait la partie
  249. C symétrique d'une matrice purement antisymétrique ...
  250. * IF(NBR.EQ.0) THEN
  251. * SEGDES MRIGID
  252. * CALL ERREUR(727)
  253. * RETURN
  254. * ENDIF
  255. C ... Mais avant on va tester si la normalisation des variables
  256. C primales et duales a été demandée - ceci entraîne la perte
  257. C de la symétrie ...
  258. IF(NORINC.GT.0 .AND. NORIND.GT.0) THEN
  259. IF(KSYMET.EQ.1) THEN
  260. CALL ERREUR(19)
  261. SEGDES,MRIGID
  262. RETURN
  263. ENDIF
  264. INSYM = 1
  265. IGRADJ = 0
  266. ICHSKI = 0
  267. GOTO 15
  268. ENDIF
  269.  
  270. IF (NRG.GE.7) THEN
  271. C ... On teste si la matrice contient des matrices non symétriques ...
  272. C ... Si OUI, ce n'est pas la peine de faire les autres tests ...
  273. DO 9 IN = 1,NBR
  274. IANTI=IRIGEL(7,IN)
  275. IF(IANTI.GT.0) THEN
  276. C ... On vérifie si l'utilisateur n'a pas demandé explicitement
  277. C la résolution par Choleski ou gradient conjugué,
  278. C si OUI on râle puis on s'en va !!! ...
  279. IF(KSYMET.EQ.1) THEN
  280. CALL ERREUR(19)
  281. SEGDES,MRIGID
  282. RETURN
  283. ENDIF
  284. IF(NORINC.NE.0.AND.NORIND.EQ.0) THEN
  285. CALL ERREUR(760)
  286. SEGDES,MRIGID
  287. RETURN
  288. ENDIF
  289. INSYM = 1
  290. IGRADJ = 0
  291. ICHSKI = 0
  292. GOTO 15
  293. ENDIF
  294. 9 CONTINUE
  295.  
  296.  
  297. ENDIF
  298.  
  299. 15 CONTINUE
  300. C
  301. C **** ON S'ASSURE QU'IL N'Y A PAS D'APPUIS UNILATERAUX
  302. C
  303. if (iunil.eq.0) goto 30
  304. IF(IRIGEL(/1).LT.6) GO TO 30
  305. IF (NOUNIL.EQ.1) GOTO 30
  306. 21 CONTINUE
  307. C
  308. C **** EXISTENCE DES APPUIS UNILATERAUX
  309. C **** SI ON EST DEJA PASSE DANS LES APPUIS UNILATERAUX
  310. C ISUPEQ POINTE SUR UNE TABLE CONTENANT LES DONNEES A PASSER
  311. C A LA PROCEDURE UNILATER
  312. C
  313. ISUPLO=ISUPEQ
  314. IF (ISUPLO.NE.0) GOTO 27
  315. NNOR=0
  316. DO 22 I=1,IRIGEL(/2)
  317. IF(IRIGEL(6,I).EQ.0) NNOR=NNOR+1
  318. 22 CONTINUE
  319. IF(NNOR.EQ.0) THEN
  320. CALL ERREUR(312)
  321. RETURN
  322. ENDIF
  323. NRIGE=IRIGEL(/1)
  324. NRIGEL=NNOR
  325. SEGINI RI1
  326. NRIGEL=IRIGEL(/2)-NNOR
  327. SEGINI RI2
  328. II1=0
  329. II2=0
  330. DO 23 I=1,IRIGEL(/2)
  331. IF(IRIGEL(6,I).NE.0) THEN
  332. RI3=RI2
  333. II2=II2+1
  334. II=II2
  335. ELSE
  336. RI3=RI1
  337. II1=II1+1
  338. II=II1
  339. ENDIF
  340. DO 24 J=1,NRIGE
  341. RI3.IRIGEL(J,II) = IRIGEL(J,I)
  342. 24 CONTINUE
  343. RI3.COERIG(II)=COERIG(I)
  344. 23 CONTINUE
  345. * RI1 raideur sans condition unilaterale
  346. * RI2 conditions unilaterales
  347. CALL CRTABL(MTABLE)
  348. ISUPEQ=MTABLE
  349. * il faut aussi mettre isupeq dans la raideur initiale
  350. if (jrsup.ne.0) mrigid=jrsup
  351. segact mrigid
  352. iri1s=jrelim
  353. iri2s=mrigid
  354. MRIGID=IPRIGO
  355. SEGACT MRIGID*MOD
  356. ISUPEQ=MTABLE
  357. if (idepe.ne.0) then
  358. * il faut extraire de la matrice initiale (ipoir0) les conditions unilaterales
  359. mrigid=iri2s
  360. segact mrigid
  361. nrigel=0
  362. do 40 i=1,irigel(/2)
  363. if (irigel(6,i).eq.0) nrigel=nrigel+1
  364. 40 continue
  365. if (nrigel.eq.0) call erreur(312)
  366. if (ierr.ne.0) return
  367. nrige=irigel(/1)
  368. segini ri4
  369. ii1=0
  370. nrigel=irigel(/2)-nrigel
  371. segini ri5
  372. ii2=0
  373. do 41 i=1,irigel(/2)
  374. if (irigel(6,i).ne.0) goto 42
  375. ii1=ii1+1
  376. do j=1,nrige
  377. ri4.irigel(j,ii1)=irigel(j,i)
  378. enddo
  379. ri4.coerig(ii1)=coerig(i)
  380. goto 41
  381. 42 continue
  382. ii2=ii2+1
  383. do j=1,nrige
  384. ri5.irigel(j,ii2)=irigel(j,i)
  385. enddo
  386. ri5.coerig(ii2)=coerig(i)
  387. 41 continue
  388. segdes mrigid,ri4
  389. endif
  390. ri3=iri1s
  391. * segact ri1,ri2,ri3,ri4,ri5
  392. CALL ECCTAB(MTABLE,'ENTIER ',1,XVA,' ',ILOG,IOB,
  393. $ 'RIGIDITE',IOB,XVA,' ',ILOG,RI1)
  394. CALL ECCTAB(MTABLE,'ENTIER ',2,XVA,' ',ILOG,IOB,
  395. $ 'RIGIDITE',IOB,XVA,' ',ILOG,RI2)
  396. CALL ECCTAB(MTABLE,'ENTIER ',3,XVA,' ',ILOG,IOB,
  397. $ 'LOGIQUE ',IOB,XVA,' ',ILOG,IOB)
  398. ** if(idepe.ne.0) then
  399. ** CALL ECCTAB(MTABLE,'ENTIER ',8,XVA,' ',ILOG,IOB,
  400. ** $ 'RIGIDITE',IOB,XVA,' ',ILOG,iri1s)
  401. ** CALL ECCTAB(MTABLE,'ENTIER ',9,XVA,' ',ILOG,IOB,
  402. ** $ 'RIGIDITE',IOB,XVA,' ',ILOG,ri4 )
  403. ** CALL ECCTAB(MTABLE,'ENTIER ',12,XVA,' ',ILOG,IOB,
  404. ** $ 'RIGIDITE',IOB,XVA,' ',ILOG,ri5 )
  405. ** endif
  406. if (lagdua.ne.0)
  407. > CALL ECCTAB(MTABLE,'ENTIER ',13,XVA,' ',ILOG,IOB,
  408. $ 'MAILLAGE',IOB,XVA,' ',ILOG,lagdua)
  409. ISUPLO=MTABLE
  410. SEGDES RI1,RI2,MTABLE
  411. 27 CONTINUE
  412. MTABLE=ISUPLO
  413. SEGACT MTABLE
  414. IF(INSYM.EQ.1) THEN
  415. ILUG=.TRUE.
  416. ELSE
  417. ILUG=.FALSE.
  418. ENDIF
  419. CALL ECCTAB(MTABLE,'MOT ',4,XVA,'NSYM',ILOG,IOB,
  420. $ 'LOGIQUE ',IOB,XVA,' ',ILUG,IOB)
  421. if(idepe.ne.0) then
  422. * on passe les ideme* a mrem sous forme de listchpo
  423. n1=if
  424. segini mlchpo,mlchp1
  425. do i=1,if
  426. mlchpo.ichpoi(i)=ideme0(1,i)
  427. mlchp1.ichpoi(i)=ideme1(1,i)
  428. enddo
  429. CALL ECCTAB(MTABLE,'ENTIER ',10,XVA,' ',ILOG,IOB,
  430. $ 'LISTCHPO',IOB,XVA,' ',ILOG,mlchpo)
  431. CALL ECCTAB(MTABLE,'ENTIER ',11,XVA,' ',ILOG,IOB,
  432. $ 'LISTCHPO',IOB,XVA,' ',ILOG,mlchp1)
  433. * pour mrem on met la derniere raideur condensee. Elle contient les pointeurs pour remonter
  434. CALL ECCTAB(MTABLE,'ENTIER ',50,XVA,' ',ILOG,IOB,
  435. $ 'RIGIDITE',IOB,XVA,' ',ILOG,ipoiri)
  436. endif
  437. SEGDES MRIGID
  438. DO 26 I=IDEMEM(/1),1,-1
  439. ISECO=IDEMEM(I)
  440. CALL ACTOBJ ('CHPOINT ',ISECO,1)
  441. CALL ECROBJ ('CHPOINT ',ISECO)
  442. 26 CONTINUE
  443. SEGSUP IDEMEM
  444. CALL ECROBJ ('TABLE ',ISUPLO)
  445. SEGINI MTEXTE
  446. LTT=8
  447. MTEXT(1:LTT) ='UNILATER'
  448. NCART=8
  449. SEGDES MTEXTE
  450. CALL ECROBJ('TEXTE',MTEXTE)
  451. mrigid=iprigo
  452. segdes mrigid
  453. RETURN
  454.  
  455. C ... On arrive ici dans le cas où il n'y a pas d'appuis unilatéraux ...
  456. 30 CONTINUE
  457. * il se peut que le dernier chp soit du frottement
  458. * on l'enleve car il ne sert a rien si on n'appele pas unilater
  459. if (idemem(/1).gt.1.and.idepe.ne.0) then
  460. mchpoi=ideme0(idemem(/1),if)
  461. segact MCHPOI
  462. if (mtypoi.eq.'LX ') idemem(/1)=idemem(/1)-1
  463. endif
  464. * frottement
  465. SEGDES IDEMEM
  466. * write(6,*) ' ichski, igradj,insym ',ichski, igradj,insym
  467. * write (6,*) ' imtvid ',imtvid
  468. if (imtvid.eq.1) then
  469. * matrice vide
  470. *** write(6,*) ' attention matrice vide. Système surcontraint '
  471. call erreur(-364)
  472. *
  473. nsoupo=0
  474. nat=0
  475. segact idemem*mod
  476.  
  477. do i=1,idemem(/1)
  478. segini mchpoi
  479. idemem(i)=mchpoi
  480. enddo
  481. if (noen.eq.0) then
  482. call ecrent(0)
  483. nbelem=0
  484. nbnn=1
  485. nbsous=0
  486. nbref=0
  487. segini ipt8
  488. ipt8.itypel=1
  489. call actobj('MAILLAGE',ipt8,1)
  490. call ecrobj('MAILLAGE',ipt8)
  491. endif
  492. else
  493. * write(6,*) ' appel resou1 -- idemem(1)'
  494. * segact idemem
  495. * idesec= idemem(1)
  496. * call ecchpo(idesec,0)
  497. * write(6,*) ' appel resou1 -- ipoiri'
  498. * call prrigi ( ipoiri,1)
  499. * write(6,*) ' ichski insym ', ichski, insym
  500. IF(ICHSKI.EQ.1) CALL RESOU1(IPOIRI,IDEMEM,NOID,NOEN,PREC,
  501. > ISTAB,ISOUCI)
  502. IF(IGRADJ.EQ.1) CALL GRACO0(IPOIRI,IDEMEM,NOID,NOEN)
  503. IF(INSYM .EQ.1) CALL LDMT (IPOIRI,IDEMEM,NOID,NOEN,PREC,ISOUCI)
  504. IF(IERR.NE.0) GO TO 5001
  505. endif
  506. C
  507. C-------------------------------------------------------
  508. C LA SOLUTION EST CALCULEE --> ON LA MET EN FORME
  509.  
  510. if (noen.eq.0) then
  511. call lirobj('MAILLAGE',ipt8,1,iretou)
  512. if (ierr.ne.0) return
  513. segact ipt8
  514. call lirent(nben,1,iretou)
  515. endif
  516.  
  517. SEGACT IDEMEM*mod
  518. N=IDEMEM(/1)
  519. do i=1,n
  520. mchpoi=idemem(i)
  521. * les champs de points qui sortent sont de nature diffuse
  522. SEGACT MCHPOI
  523. NAT = MAX(1,JATTRI(/1))
  524. NSOUPO=IPCHP(/1)
  525. SEGADJ MCHPOI
  526. JATTRI(1)=1
  527. enddo
  528.  
  529.  
  530. do 2010 ifois=1,30
  531. segact mrigid
  532. mrigid=jrsup
  533. if (mrigid.eq.0) goto 2011
  534. if(ierr.ne.0) return
  535. call resour(idemem,ideme0,ideme1,mrigid,if,noen,ipt8,
  536. > isouci,iverif)
  537. if (ierr.ne.0) return
  538. if=if-1
  539. 2010 continue
  540. 2011 continue
  541. *
  542. * on n'appelle plus verlx car je ne vois pas pourquoi on voudrait que les multiplicateurs de lagrange non éliminés soient nuls
  543. *
  544. **** call verlx(ri2,iret,mchpo1,noen,ipt8)
  545. if (noen.eq.0) then
  546. call actobj('MAILLAGE',ipt8,1)
  547. call ecrobj('MAILLAGE',ipt8)
  548. nben=ipt8.num(/2)
  549. call ecrent(nben)
  550. endif
  551. *
  552. do 3 i=1,n
  553. iret=idemem(n+1-i)
  554.  
  555. * cas table de liaisons statiques
  556. if (itbas.ne.0) then
  557. il = n + 1 - i
  558. ilo = idnote(il)
  559. CALL ACCTAB(ITBAS,'ENTIER',ILO,0.d0,' ',.true.,IP0,
  560. & 'TABLE',I1,X1,CHARRE,.true.,ITMOD)
  561. if (ierr.ne.0) return
  562. c CALL CREPO1 (ZERO, ZERO, ZERO, IPOIN)
  563. c CALL ECCTAB(ITMOD,'MOT',0,0.0D0,'POINT_REPERE',.TRUE.,0,
  564. c & 'POINT',0,0.0D0,' ',.TRUE.,IPOIN)
  565.  
  566. CALL ECCTAB(ITMOD,'MOT',0,0.D0,'DEFORMEE',
  567. & .TRUE.,0,'CHPOINT',0,0.D0,' ',.TRUE.,IRET)
  568.  
  569. else if (ipshpo.gt.0) then
  570. mlchpo = ipshpo
  571. ichpoi(N+1-I) = iret
  572. else
  573. CALL ACTOBJ ('CHPOINT ',IRET,1)
  574. CALL ECROBJ ('CHPOINT ',IRET)
  575. endif
  576.  
  577. 3 CONTINUE
  578. c-----fin de boucle sur les solutions
  579.  
  580.  
  581. C-------------------------------------------------------
  582. c MENAGE AVANT DE QUITTER
  583.  
  584. 5001 CONTINUE
  585. if (itbas.ne.0) then
  586. segdes mtab1
  587. segsup idnote
  588. CALL ECROBJ ('TABLE ',itbas)
  589. endif
  590.  
  591. if (ipshpo.gt.0) then
  592. mlchpo = ipshpo
  593. CALL ACTOBJ ('LISTCHPO ',ipshpo,1)
  594. CALL ECROBJ ('LISTCHPO ',ipshpo)
  595. endif
  596. SEGSUP IDEMEM
  597. C
  598. 5000 CONTINUE
  599. END
  600.  
  601.  
  602.  
  603.  
  604.  
  605.  
  606.  
  607.  

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