Télécharger resou.eso

Retour à la liste

Numérotation des lignes :

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

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