Télécharger resou.eso

Retour à la liste

Numérotation des lignes :

  1. C RESOU SOURCE PV 20/05/12 21:15:10 10614
  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. 1000 continue
  197. * elimination recursive des conditions aux limites
  198. * on la fait en gradient conjugue ou en appel de unilater
  199. nfois=nelim-1
  200. if (igradj.eq.1.or.(iunil.eq.1.and.nounil.eq.0)) nfois=29
  201. lagdua=0
  202. imult=1
  203. icond=idepe
  204. icondi=icond+1
  205. if=0
  206. do ifois=1,nfois
  207. if(imult.ne.0.and.icond.ne.0.and.
  208. > (icondi-icond.gt.0.or.igradj.eq.1)) then
  209. icondi=icond
  210. lagdua=-1
  211. if=if+1
  212. if(ierr.ne.0) return
  213. call resouc(mrigid,mrigic,idemem,ideme0,ideme1,
  214. > nounil,lagdua,icond,imult,if,imtvid,nelim)
  215. ** write(6,*) ' passe ',if,' condition ',icond
  216. if(ierr.ne.0) return
  217. mrigid=mrigic
  218. endif
  219. enddo
  220. * Si on n'a pas reussi a tout eliminer, on fait encore une passe pour creer lagdua
  221. lagdua=0
  222. if (iunil.eq.0.or.nounil.eq.1) then
  223. if (icond.ne.0) then
  224. if=if+1
  225. if(ierr.ne.0) return
  226. call resouc(mrigid,mrigic,idemem,ideme0,ideme1,
  227. > nounil,lagdua,icond,imult,if,imtvid,nelim)
  228. ** write(6,*) ' passe ','finale',' condition ',icond
  229. if(ierr.ne.0) return
  230. mrigid=mrigic
  231. endif
  232. endif
  233. ** write (6,*) 'nombre de passes',if
  234. if (idepe.ne.0) noid = 1
  235. ipoiri=mrigid
  236. * call prrigi(ipoiri,1)
  237. C-------------------------------------------------------
  238.  
  239. *
  240. * Si au moins une des matrices n'est pas symétrique, on passera
  241. * par le solveur non-symétrique LDMT.
  242. *
  243. SEGACT MRIGID*MOD
  244. NRG = IRIGEL(/1)
  245. NBR = IRIGEL(/2)
  246. C ... Ceci peut arriver si par exemple on extrait la partie
  247. C symétrique d'une matrice purement antisymétrique ...
  248. * IF(NBR.EQ.0) THEN
  249. * SEGDES MRIGID
  250. * CALL ERREUR(727)
  251. * RETURN
  252. * ENDIF
  253. C ... Mais avant on va tester si la normalisation des variables
  254. C primales et duales a été demandée - ceci entraîne la perte
  255. C de la symétrie ...
  256. IF(NORINC.GT.0 .AND. NORIND.GT.0) THEN
  257. IF(KSYMET.EQ.1) THEN
  258. CALL ERREUR(19)
  259. SEGDES,MRIGID
  260. RETURN
  261. ENDIF
  262. INSYM = 1
  263. IGRADJ = 0
  264. ICHSKI = 0
  265. GOTO 15
  266. ENDIF
  267.  
  268. IF (NRG.GE.7) THEN
  269. C ... On teste si la matrice contient des matrices non symétriques ...
  270. C ... Si OUI, ce n'est pas la peine de faire les autres tests ...
  271. DO 9 IN = 1,NBR
  272. IANTI=IRIGEL(7,IN)
  273. IF(IANTI.GT.0) THEN
  274. C ... On vérifie si l'utilisateur n'a pas demandé explicitement
  275. C la résolution par Choleski ou gradient conjugué,
  276. C si OUI on râle puis on s'en va !!! ...
  277. IF(KSYMET.EQ.1) THEN
  278. CALL ERREUR(19)
  279. SEGDES,MRIGID
  280. RETURN
  281. ENDIF
  282. IF(NORINC.NE.0.AND.NORIND.EQ.0) THEN
  283. CALL ERREUR(760)
  284. SEGDES,MRIGID
  285. RETURN
  286. ENDIF
  287. INSYM = 1
  288. IGRADJ = 0
  289. ICHSKI = 0
  290. GOTO 15
  291. ENDIF
  292. 9 CONTINUE
  293.  
  294.  
  295. ENDIF
  296.  
  297. 15 CONTINUE
  298. C
  299. C **** ON S'ASSURE QU'IL N'Y A PAS D'APPUIS UNILATERAUX
  300. C
  301. if (iunil.eq.0) goto 30
  302. IF(IRIGEL(/1).LT.6) GO TO 30
  303. IF (NOUNIL.EQ.1) GOTO 30
  304. 21 CONTINUE
  305. C
  306. C **** EXISTENCE DES APPUIS UNILATERAUX
  307. C **** SI ON EST DEJA PASSE DANS LES APPUIS UNILATERAUX
  308. C ISUPEQ POINTE SUR UNE TABLE CONTENANT LES DONNEES A PASSER
  309. C A LA PROCEDURE UNILATER
  310. C
  311. ISUPLO=ISUPEQ
  312. IF (ISUPLO.NE.0) GOTO 27
  313. NNOR=0
  314. DO 22 I=1,IRIGEL(/2)
  315. IF(IRIGEL(6,I).EQ.0) NNOR=NNOR+1
  316. 22 CONTINUE
  317. IF(NNOR.EQ.0) THEN
  318. CALL ERREUR(312)
  319. RETURN
  320. ENDIF
  321. NRIGE=IRIGEL(/1)
  322. NRIGEL=NNOR
  323. SEGINI RI1
  324. NRIGEL=IRIGEL(/2)-NNOR
  325. SEGINI RI2
  326. II1=0
  327. II2=0
  328. DO 23 I=1,IRIGEL(/2)
  329. IF(IRIGEL(6,I).NE.0) THEN
  330. RI3=RI2
  331. II2=II2+1
  332. II=II2
  333. ELSE
  334. RI3=RI1
  335. II1=II1+1
  336. II=II1
  337. ENDIF
  338. DO 24 J=1,NRIGE
  339. RI3.IRIGEL(J,II) = IRIGEL(J,I)
  340. 24 CONTINUE
  341. RI3.COERIG(II)=COERIG(I)
  342. 23 CONTINUE
  343. * RI1 raideur sans condition unilaterale
  344. * RI2 conditions unilaterales
  345. CALL CRTABL(MTABLE)
  346. ISUPEQ=MTABLE
  347. * il faut aussi mettre isupeq dans la raideur initiale
  348. if (jrsup.ne.0) mrigid=jrsup
  349. segact mrigid
  350. iri1s=jrelim
  351. iri2s=mrigid
  352. MRIGID=IPRIGO
  353. SEGACT MRIGID*MOD
  354. ISUPEQ=MTABLE
  355. if (idepe.ne.0) then
  356. * il faut extraire de la matrice initiale (ipoir0) les conditions unilaterales
  357. mrigid=iri2s
  358. segact mrigid
  359. nrigel=0
  360. do 40 i=1,irigel(/2)
  361. if (irigel(6,i).eq.0) nrigel=nrigel+1
  362. 40 continue
  363. if (nrigel.eq.0) call erreur(312)
  364. if (ierr.ne.0) return
  365. nrige=irigel(/1)
  366. segini ri4
  367. ii1=0
  368. nrigel=irigel(/2)-nrigel
  369. segini ri5
  370. ii2=0
  371. do 41 i=1,irigel(/2)
  372. if (irigel(6,i).ne.0) goto 42
  373. ii1=ii1+1
  374. do j=1,nrige
  375. ri4.irigel(j,ii1)=irigel(j,i)
  376. enddo
  377. ri4.coerig(ii1)=coerig(i)
  378. goto 41
  379. 42 continue
  380. ii2=ii2+1
  381. do j=1,nrige
  382. ri5.irigel(j,ii2)=irigel(j,i)
  383. enddo
  384. ri5.coerig(ii2)=coerig(i)
  385. 41 continue
  386. segdes mrigid,ri4
  387. endif
  388. ri3=iri1s
  389. * segact ri1,ri2,ri3,ri4,ri5
  390. CALL ECCTAB(MTABLE,'ENTIER ',1,XVA,' ',ILOG,IOB,
  391. $ 'RIGIDITE',IOB,XVA,' ',ILOG,RI1)
  392. CALL ECCTAB(MTABLE,'ENTIER ',2,XVA,' ',ILOG,IOB,
  393. $ 'RIGIDITE',IOB,XVA,' ',ILOG,RI2)
  394. CALL ECCTAB(MTABLE,'ENTIER ',3,XVA,' ',ILOG,IOB,
  395. $ 'LOGIQUE ',IOB,XVA,' ',ILOG,IOB)
  396. ** if(idepe.ne.0) then
  397. ** CALL ECCTAB(MTABLE,'ENTIER ',8,XVA,' ',ILOG,IOB,
  398. ** $ 'RIGIDITE',IOB,XVA,' ',ILOG,iri1s)
  399. ** CALL ECCTAB(MTABLE,'ENTIER ',9,XVA,' ',ILOG,IOB,
  400. ** $ 'RIGIDITE',IOB,XVA,' ',ILOG,ri4 )
  401. ** CALL ECCTAB(MTABLE,'ENTIER ',12,XVA,' ',ILOG,IOB,
  402. ** $ 'RIGIDITE',IOB,XVA,' ',ILOG,ri5 )
  403. ** endif
  404. if (lagdua.ne.0)
  405. > CALL ECCTAB(MTABLE,'ENTIER ',13,XVA,' ',ILOG,IOB,
  406. $ 'MAILLAGE',IOB,XVA,' ',ILOG,lagdua)
  407. ISUPLO=MTABLE
  408. SEGDES RI1,RI2,MTABLE
  409. 27 CONTINUE
  410. MTABLE=ISUPLO
  411. SEGACT MTABLE
  412. IF(INSYM.EQ.1) THEN
  413. ILUG=.TRUE.
  414. ELSE
  415. ILUG=.FALSE.
  416. ENDIF
  417. CALL ECCTAB(MTABLE,'MOT ',4,XVA,'NSYM',ILOG,IOB,
  418. $ 'LOGIQUE ',IOB,XVA,' ',ILUG,IOB)
  419. if(idepe.ne.0) then
  420. * on passe les ideme* a mrem sous forme de listchpo
  421. n1=if
  422. segini mlchpo,mlchp1
  423. do i=1,if
  424. mlchpo.ichpoi(i)=ideme0(1,i)
  425. mlchp1.ichpoi(i)=ideme1(1,i)
  426. enddo
  427. CALL ECCTAB(MTABLE,'ENTIER ',10,XVA,' ',ILOG,IOB,
  428. $ 'LISTCHPO',IOB,XVA,' ',ILOG,mlchpo)
  429. CALL ECCTAB(MTABLE,'ENTIER ',11,XVA,' ',ILOG,IOB,
  430. $ 'LISTCHPO',IOB,XVA,' ',ILOG,mlchp1)
  431. * pour mrem on met la derniere raideur condensee. Elle contient les pointeurs pour remonter
  432. CALL ECCTAB(MTABLE,'ENTIER ',50,XVA,' ',ILOG,IOB,
  433. $ 'RIGIDITE',IOB,XVA,' ',ILOG,ipoiri)
  434. endif
  435. SEGDES MRIGID
  436. DO 26 I=IDEMEM(/1),1,-1
  437. ISECO=IDEMEM(I)
  438. CALL ACTOBJ ('CHPOINT ',ISECO,1)
  439. CALL ECROBJ ('CHPOINT ',ISECO)
  440. 26 CONTINUE
  441. SEGSUP IDEMEM
  442. CALL ECROBJ ('TABLE ',ISUPLO)
  443. SEGINI MTEXTE
  444. LTT=8
  445. MTEXT(1:LTT) ='UNILATER'
  446. NCART=8
  447. SEGDES MTEXTE
  448. CALL ECROBJ('TEXTE',MTEXTE)
  449. mrigid=iprigo
  450. segdes mrigid
  451. RETURN
  452.  
  453. C ... On arrive ici dans le cas où il n'y a pas d'appuis unilatéraux ...
  454. 30 CONTINUE
  455. * il se peut que le dernier chp soit du frottement
  456. * on l'enleve car il ne sert a rien si on n'appele pas unilater
  457. if (idemem(/1).gt.1.and.idepe.ne.0) then
  458. mchpoi=ideme0(idemem(/1),if)
  459. segact MCHPOI
  460. if (mtypoi.eq.'LX ') idemem(/1)=idemem(/1)-1
  461. endif
  462. * frottement
  463. SEGDES IDEMEM
  464. * write(6,*) ' ichski, igradj,insym ',ichski, igradj,insym
  465. * write (6,*) ' imtvid ',imtvid
  466. if (imtvid.eq.1) then
  467. * matrice vide
  468. *** write(6,*) ' attention matrice vide. Système surcontraint '
  469. call erreur(-364)
  470. *
  471. nsoupo=0
  472. nat=0
  473. segact idemem*mod
  474.  
  475. do i=1,idemem(/1)
  476. segini mchpoi
  477. idemem(i)=mchpoi
  478. enddo
  479. if (noen.eq.0) then
  480. call ecrent(0)
  481. nbelem=0
  482. nbnn=1
  483. nbsous=0
  484. nbref=0
  485. segini ipt8
  486. ipt8.itypel=1
  487. call actobj('MAILLAGE',ipt8,1)
  488. call ecrobj('MAILLAGE',ipt8)
  489. endif
  490. else
  491. * write(6,*) ' appel resou1 -- idemem(1)'
  492. * segact idemem
  493. * idesec= idemem(1)
  494. * call ecchpo(idesec,0)
  495. * write(6,*) ' appel resou1 -- ipoiri'
  496. * call prrigi ( ipoiri,1)
  497. * write(6,*) ' ichski insym ', ichski, insym
  498. IF(ICHSKI.EQ.1) CALL RESOU1(IPOIRI,IDEMEM,NOID,NOEN,PREC,
  499. > ISTAB,ISOUCI)
  500. IF(IGRADJ.EQ.1) CALL GRACO0(IPOIRI,IDEMEM,NOID,NOEN)
  501. IF(INSYM .EQ.1) CALL LDMT (IPOIRI,IDEMEM,NOID,NOEN,PREC,ISOUCI)
  502. IF(IERR.NE.0) GO TO 5001
  503. endif
  504. C
  505. C-------------------------------------------------------
  506. C LA SOLUTION EST CALCULEE --> ON LA MET EN FORME
  507.  
  508. if (noen.eq.0) then
  509. call lirobj('MAILLAGE',ipt8,1,iretou)
  510. if (ierr.ne.0) return
  511. segact ipt8
  512. call lirent(nben,1,iretou)
  513. endif
  514.  
  515. SEGACT IDEMEM*mod
  516. N=IDEMEM(/1)
  517. do i=1,n
  518. mchpoi=idemem(i)
  519. * les champs de points qui sortent sont de nature diffuse
  520. SEGACT MCHPOI
  521. NAT = MAX(1,JATTRI(/1))
  522. NSOUPO=IPCHP(/1)
  523. SEGADJ MCHPOI
  524. JATTRI(1)=1
  525. enddo
  526.  
  527.  
  528. do 2010 ifois=1,30
  529. segact mrigid
  530. mrigid=jrsup
  531. if (mrigid.eq.0) goto 2011
  532. if(ierr.ne.0) return
  533. call resour(idemem,ideme0,ideme1,mrigid,if,noen,ipt8,
  534. > isouci,iverif)
  535. if (ierr.ne.0) return
  536. if=if-1
  537. 2010 continue
  538. 2011 continue
  539. *
  540. * on n'appelle plus verlx car je ne vois pas pourquoi on voudrait que les multiplicateurs de lagrange non éliminés soient nuls
  541. *
  542. **** call verlx(ri2,iret,mchpo1,noen,ipt8)
  543. if (noen.eq.0) then
  544. call actobj('MAILLAGE',ipt8,1)
  545. call ecrobj('MAILLAGE',ipt8)
  546. nben=ipt8.num(/2)
  547. call ecrent(nben)
  548. endif
  549. *
  550. do 3 i=1,n
  551. iret=idemem(n+1-i)
  552.  
  553. * cas table de liaisons statiques
  554. if (itbas.ne.0) then
  555. il = n + 1 - i
  556. ilo = idnote(il)
  557. CALL ACCTAB(ITBAS,'ENTIER',ILO,0.d0,' ',.true.,IP0,
  558. & 'TABLE',I1,X1,CHARRE,.true.,ITMOD)
  559. if (ierr.ne.0) return
  560. c CALL CREPO1 (ZERO, ZERO, ZERO, IPOIN)
  561. c CALL ECCTAB(ITMOD,'MOT',0,0.0D0,'POINT_REPERE',.TRUE.,0,
  562. c & 'POINT',0,0.0D0,' ',.TRUE.,IPOIN)
  563.  
  564. CALL ECCTAB(ITMOD,'MOT',0,0.D0,'DEFORMEE',
  565. & .TRUE.,0,'CHPOINT',0,0.D0,' ',.TRUE.,IRET)
  566.  
  567. else if (ipshpo.gt.0) then
  568. mlchpo = ipshpo
  569. ichpoi(N+1-I) = iret
  570. else
  571. CALL ACTOBJ ('CHPOINT ',IRET,1)
  572. CALL ECROBJ ('CHPOINT ',IRET)
  573. endif
  574.  
  575. 3 CONTINUE
  576. c-----fin de boucle sur les solutions
  577.  
  578.  
  579. C-------------------------------------------------------
  580. c MENAGE AVANT DE QUITTER
  581.  
  582. 5001 CONTINUE
  583. if (itbas.ne.0) then
  584. segdes mtab1
  585. segsup idnote
  586. CALL ECROBJ ('TABLE ',itbas)
  587. endif
  588.  
  589. if (ipshpo.gt.0) then
  590. mlchpo = ipshpo
  591. CALL ACTOBJ ('LISTCHPO ',ipshpo,1)
  592. CALL ECROBJ ('LISTCHPO ',ipshpo)
  593. endif
  594. SEGSUP IDEMEM
  595. C
  596. 5000 CONTINUE
  597. END
  598.  
  599.  
  600.  
  601.  
  602.  

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