Télécharger prfuse.eso

Retour à la liste

Numérotation des lignes :

  1. C PRFUSE SOURCE PASCAL 20/07/06 21:15:08 10640
  2. SUBROUTINE PRFUSE
  3.  
  4. *=============================================================
  5. *
  6. * Interface entre la directive "ET" et le sous-programme "FUSE"
  7. *
  8. *=============================================================
  9. *
  10. * Modifications :
  11. *
  12. * PM 09/10/2007 : fusion de deux LISTCHPOs
  13. * PM 09/10/2007 : respect de l'ordre des opérandes
  14. * CB 23/01/2017 : ET entre un LISTMOT et un MOT
  15. *
  16. *=============================================================
  17. *
  18. * Remarques :
  19. *
  20. *=============================================================
  21.  
  22. IMPLICIT INTEGER(I-N)
  23. IMPLICIT REAL*8(A-H,O-Z)
  24.  
  25.  
  26. -INC PPARAM
  27. -INC CCOPTIO
  28. -INC SMTABLE
  29. -INC CCNOYAU
  30. -INC CCASSIS
  31. -INC SMELEME
  32. -INC SMLMOTS
  33. -INC CCGEOME
  34. -INC SMLREEL
  35. -INC SMLENTI
  36. -INC SMANNOT
  37.  
  38. EXTERNAL LONG
  39.  
  40. LOGICAL IR1,IR2,IR3,LTELQ
  41. CHARACTER*(8) CTYP,CTYP2,ICHAT,TYPRET,TYPRE1
  42. CHARACTER*(512) LEMOT,LEMOT1,LEMOT2
  43. REAL*8 XVAL
  44. CHARACTER*4 LISTMO(1)
  45. DATA LISTMO / 'TELQ' /
  46.  
  47. IP0 = 0
  48. IP1 = 0
  49. IP2 = 0
  50.  
  51. * Recherche préalable du mot-clef 'TELQUEL' éventuel
  52. CALL LIRMOT(LISTMO,1,IRE2,0)
  53. IF (IERR.NE.0) RETURN
  54. LTELQ = (IRE2.EQ.1)
  55.  
  56. * Lecture du premier objet
  57. * ------------------------
  58. CALL MESLIR(-225)
  59. CALL QUETYP(CTYP,0,IRETOU)
  60. IF(IRETOU.EQ.0) THEN
  61. * Cet opérateur a encore besoin d'un opérande.
  62. CALL ERREUR (533)
  63. RETURN
  64. ENDIF
  65.  
  66. IF(CTYP.EQ.'LOGIQUE ') THEN
  67. CALL MESLIR(-225)
  68. CALL LIRLOG(IR1,1,IRETOU)
  69. CALL MESLIR(-223)
  70. CALL LIRLOG(IR2,1,IRETOU)
  71. IF(IERR.NE.0) RETURN
  72. GOTO 213
  73.  
  74. ELSE IF(CTYP.EQ.'MOT ') THEN
  75. CALL LIRCHA(LEMOT1,1,IRET1)
  76. IF (IERR.NE.0) RETURN
  77.  
  78. CALL QUETYP(CTYP2,0,IRETOU)
  79. IF(IRETOU.EQ.0) THEN
  80. * Cet opérateur a encore besoin d'un opérande.
  81. CALL ERREUR (533)
  82. RETURN
  83. ENDIF
  84. IF(CTYP2 .EQ. 'LISTMOTS') THEN
  85. CALL LIROBJ('LISTMOTS',IP2,1,IRETOU)
  86. IF(IERR.NE.0) RETURN
  87. GOTO 222
  88.  
  89. ELSE
  90. CALL LIRCHA(LEMOT2,1,IRET2)
  91. IF( IERR.NE.0) RETURN
  92. IF (LTELQ) THEN
  93. * Concaténation avec respect des espaces avant et après
  94. ELSE
  95. * Suppressions des espaces en fin de mot
  96. IRET1=LONG(LEMOT1)
  97. IRET2=LONG(LEMOT2)
  98. ENDIF
  99. GOTO 225
  100. ENDIF
  101.  
  102. ELSE IF(CTYP.EQ.'FLOTTANT') THEN
  103. CALL LIRREE(XVAL1,1,IRETOU)
  104. IF(IERR.NE.0) RETURN
  105. CTYP='LISTREEL'
  106. II=16
  107. GOTO 24
  108.  
  109. ELSE IF(CTYP.EQ.'ENTIER ') THEN
  110. CALL LIRENT(IP1,1,IRETOU)
  111. IF(IERR.NE.0) RETURN
  112. * suivant que l'objet suivant est un ENTIER/LISTENTI ou pas,
  113. * on considère cette entrée comme un FLOTTANT
  114. CALL QUETYP(CTYP,1,IRETOU)
  115. IF(IERR.NE.0) RETURN
  116. IF(CTYP.NE.'ENTIER '.AND.CTYP.NE.'LISTENTI') THEN
  117. XVAL1=FLOAT(IP1)
  118. IP1=0
  119. CTYP='LISTREEL'
  120. II=16
  121. ELSE
  122. CALL CRELEC(IP1)
  123. CTYP='LISTENTI'
  124. II=17
  125. ENDIF
  126. GOTO 24
  127.  
  128. ELSE
  129. MOTERR(1:8)=CTYP
  130. CALL MESLIR(-222)
  131. CALL LIROBJ(CTYP,IP1,1,IRETOU)
  132. IF(CTYP.EQ.'POINT ') THEN
  133. II = 1
  134. GOTO 24
  135. ENDIF
  136. IF(CTYP.EQ.'MAILLAGE') THEN
  137. II = 2
  138. GOTO 24
  139. ENDIF
  140. IF(CTYP.EQ.'CHPOINT ') THEN
  141. CALL ACTOBJ(CTYP,IP1,1)
  142. II = 3
  143. GOTO 24
  144. ENDIF
  145. IF(CTYP.EQ.'MCHAML ') THEN
  146. CALL ACTOBJ(CTYP,IP1,1)
  147. II = 20
  148. GOTO 24
  149. ENDIF
  150. IF(CTYP.EQ.'RIGIDITE') THEN
  151. II = 4
  152. GOTO 24
  153. ENDIF
  154. IF(CTYP.EQ.'EVOLUTIO') THEN
  155. II = 18
  156. GOTO 24
  157. ENDIF
  158. IF(CTYP.EQ.'CHARGEME') THEN
  159. II = 15
  160. GOTO 24
  161. ENDIF
  162. IF(CTYP.EQ.'STRUCTUR') THEN
  163. II = 5
  164. GOTO 24
  165. ENDIF
  166. IF(CTYP.EQ.'SOLUTION') THEN
  167. II = 6
  168. GOTO 24
  169. ENDIF
  170. IF(CTYP.EQ.'ATTACHE ') THEN
  171. II = 7
  172. GOTO 24
  173. ENDIF
  174. IF(CTYP.EQ.'ELEMSTRU') THEN
  175. II = 10
  176. GOTO 24
  177. ENDIF
  178. IF(CTYP.EQ.'BLOQSTRU') THEN
  179. II = 11
  180. GOTO 24
  181. ENDIF
  182. IF(CTYP.EQ.'BASEMODA') THEN
  183. II = 12
  184. GOTO 24
  185. ENDIF
  186. IF(CTYP.EQ.'DEFORME ') THEN
  187. II = 13
  188. GOTO 24
  189. ENDIF
  190. IF(CTYP.EQ.'VECTEUR ') THEN
  191. II = 14
  192. GOTO 24
  193. ENDIF
  194. IF(CTYP.EQ.'LISTREEL') THEN
  195. II = 16
  196. GOTO 24
  197. ENDIF
  198. IF(CTYP.EQ.'LISTENTI') THEN
  199. II = 17
  200. GOTO 24
  201. ENDIF
  202. IF(CTYP.EQ.'MMODEL ') THEN
  203. CALL ACTOBJ(CTYP,IP1,1)
  204. II = 19
  205. GOTO 24
  206. ENDIF
  207. IF(CTYP.EQ.'LISTMOTS') THEN
  208. II = 21
  209. GOTO 24
  210. ENDIF
  211. IF(CTYP.EQ.'NUAGE ') THEN
  212. II = 22
  213. GOTO 24
  214. ENDIF
  215. IF(CTYP.EQ.'MATRIK') THEN
  216. II = 23
  217. GOTO 24
  218. ENDIF
  219. IF(CTYP.EQ.'LISTCHPO') THEN
  220. II = 24
  221. GOTO 24
  222. ENDIF
  223. IF(CTYP.EQ.'ANNOTATI') THEN
  224. II = 25
  225. GOTO 24
  226. ENDIF
  227.  
  228. IF(CTYP.EQ.'TABLE') THEN
  229. MTABLE = IP1
  230. CALL ACCTAB(MTABLE,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,0,
  231. > 'MOT',ID3,RR1,LEMOT,IR1,ID2)
  232. IF (LEMOT.EQ.'LIAISONS_STATIQUES'.OR.
  233. > LEMOT.EQ.'BASE_MODALE') GOTO 2000
  234. GOTO 1000
  235. ENDIF
  236.  
  237. GOTO 999
  238.  
  239. ENDIF
  240.  
  241.  
  242. * ================
  243. * Première syntaxe
  244. * ================
  245.  
  246. * Lecture deuxième objet, lui aussi avec pointeur
  247. * -----------------------------------------------
  248. 24 CONTINUE
  249.  
  250. ICODE=1
  251. * pour les fusions mixtes, on est encore indécis sur le type du
  252. * deuxième objet.
  253. IF(CTYP.EQ.'POINT '.OR.CTYP.EQ.'MAILLAGE'.OR.
  254. & CTYP.EQ.'LISTENTI'.OR.CTYP.EQ.'LISTREEL'.OR.
  255. & CTYP.EQ.'LISTMOTS'.OR.
  256. & CTYP.EQ.'CHPOINT '.OR.CTYP.EQ.'LISTCHPO') ICODE=0
  257.  
  258. * on lit a priori un objet de même type que le premier
  259. MOTERR(1:8)=CTYP
  260. CALL MESLIR(-221)
  261. CALL LIROBJ(CTYP,IP2,ICODE,IRETOU)
  262. IF((IRETOU .EQ. 1) .AND.
  263. & (CTYP .EQ. 'CHPOINT ' .OR. CTYP .EQ. 'MCHAML ' .OR.
  264. & CTYP .EQ. 'MMODEL ')) CALL ACTOBJ(CTYP,IP2,1)
  265. IF(IERR.NE.0) RETURN
  266.  
  267. GOTO ( 1,2,3,4,205,206,207,999,999,210,211,212,214,215,216,
  268. $ 217,218,219,220,221,222,223,224,226,227),II
  269.  
  270. *-- Création maillage
  271. 1 CONTINUE
  272. CALL CRELEM(IP1)
  273. 2 CONTINUE
  274. IF (CTYP.NE.'POINT '.AND.CTYP.NE.'MAILLAGE') GOTO 999
  275. IF(IRETOU.EQ.1.AND.CTYP.EQ.'POINT ') THEN
  276. * on a deux points
  277. CALL CRELEM(IP2)
  278. ENDIF
  279. IF(IRETOU.EQ.0) THEN
  280. * on a lu des objets de types différents mais compatibles
  281. CALL MESLIR(-220)
  282. IF(CTYP.EQ.'POINT ') CALL LIROBJ('MAILLAGE',IP2,1,IRETAU)
  283. IF(CTYP.EQ.'MAILLAGE') THEN
  284. CALL LIROBJ('POINT ',IP2,1,IRETAU)
  285. IF(IRETAU.EQ.1) CALL CRELEM(IP2)
  286. ENDIF
  287. IF(IERR.NE.0) RETURN
  288. ENDIF
  289. CTYP='MAILLAGE'
  290. CALL FUSE(IP1,IP2,IRETOU,LTELQ)
  291. GOTO 100
  292.  
  293. *-- Création CHPOINT
  294. 3 CONTINUE
  295. IF(IRETOU.EQ.1) THEN
  296. * La concaténation de deux champ-points donne un champ-point
  297. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  298. CALL FUCHPO(IP1,IP2,IRETOU)
  299. IF (IRETOU.NE.IP1.AND.IRETOU.NE.IP2)
  300. & CALL ACTOBJ('CHPOINT ',IRETOU,1)
  301. GOTO 100
  302. ELSE
  303. *PM autrement, on peut obtenir une liste de chpoints
  304. CALL CRLCHP(IP1)
  305. GOTO 226
  306. ENDIF
  307.  
  308. *-- Création RIGIDITE
  309. 4 CONTINUE
  310. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  311. CALL FUSRIG(IP1,IP2,IRETOU)
  312. GOTO 100
  313. *-- Création STRUCTURE
  314. 205 CONTINUE
  315. CALL FUSTRU(IP1,IP2,IRETOU)
  316. GOTO 100
  317. *-- Création SOLUTION
  318. 206 CONTINUE
  319. CALL FUSOLU(IP1,IP2,IRETOU)
  320. GOTO 100
  321. *-- Création ATTACHE
  322. 207 CONTINUE
  323. CALL FUSATT(IP1,IP2,IRETOU)
  324. GOTO 100
  325. *-- Création ELEMSTRU
  326. 210 CONTINUE
  327. CALL FUSELS(IP1,IP2,IRETOU)
  328. GOTO 100
  329. *-- Création BLOQSTRU
  330. 211 CONTINUE
  331. CALL FUSCLS(IP1,IP2,IRETOU)
  332. GOTO 100
  333. *-- Création BASE MODALE
  334. 212 CONTINUE
  335. CALL FUSBAS(IP1,IP2,IRETOU)
  336. GOTO 100
  337. *-- Opération LOGIQUE
  338. 213 CONTINUE
  339. IR3=IR1.AND.IR2
  340. CALL ECRLOG(IR3)
  341. RETURN
  342. *-- Création DEFORMEE
  343. 214 CONTINUE
  344. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  345. CALL FUSDEF(IP1,IP2,IRETOU)
  346. GOTO 100
  347. *-- Création VECTEUR
  348. 215 CONTINUE
  349. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  350. CALL FUSVEC (IP1,IP2,IRETOU)
  351. GOTO 100
  352. *-- Création CHARGEMENT
  353. 216 CONTINUE
  354. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  355. CALL FUSCHA(IP1,IP2,IRETOU)
  356. GOTO 100
  357.  
  358. *-- Création LISTREEL
  359. 217 CONTINUE
  360. IF(IP1 .NE. 0)THEN
  361. C On a lu un LISTREEL en 1er argument
  362. IF(IRETOU.EQ.0) THEN
  363. C On n'a pas lu un LISTREEL en 2eme argument
  364. CALL QUETYP(CTYP,1,IRETOU)
  365. IF(IERR.NE.0) RETURN
  366. IF((CTYP.NE.'ENTIER ').AND.(CTYP.NE.'FLOTTANT')) GOTO 999
  367. C On a lu des objets de types différents mais compatibles
  368. IF (CTYP.EQ.'ENTIER ') THEN
  369. CALL LIRENT(IVAL2,1,IRETOU)
  370. XVAL2=FLOAT(IVAL2)
  371. ELSE
  372. CALL LIRREE(XVAL2,1,IRETOU)
  373. ENDIF
  374. IF(IERR.NE.0) RETURN
  375.  
  376. MLREE2=IP1
  377. SEGACT,MLREE2
  378. JG1=MLREE2.PROG(/1)
  379. JG =JG1 + 1
  380. SEGINI,MLREE1
  381. MLREE1.PROG(JG)=XVAL2
  382. IF(JG1 .GT. 0)THEN
  383. C Recopie en FORTRAN
  384. CALL OPTABJ(1,1,3,1,
  385. & MLREE2.PROG(1),MLREE2.PROG(1),MLREE1.PROG(1),
  386. & JG1 ,JG1 ,JG1,
  387. & 1,0,0.D0,IRETOU)
  388. ENDIF
  389. ELSE
  390. C On a lu un LISTREEL en 2eme argument
  391. CALL FUSPRO(IP1,IP2,IRETOU)
  392. MLREE1=IRETOU
  393. ENDIF
  394. ELSE
  395. C On n'a pas lu un LISTREEL en 1er argument
  396. IF(IRETOU.EQ.0) THEN
  397. C On n'a pas lu un LISTREEL en 2eme argument
  398. CALL QUETYP(CTYP,1,IRETOU)
  399. IF(IERR.NE.0) RETURN
  400. IF((CTYP.NE.'ENTIER ').AND.(CTYP.NE.'FLOTTANT')) GOTO 999
  401. C On a lu des objets de types différents mais compatibles
  402. IF (CTYP.EQ.'ENTIER ') THEN
  403. CALL LIRENT(IVAL2,1,IRETOU)
  404. XVAL2=FLOAT(IVAL2)
  405. ELSE
  406. CALL LIRREE(XVAL2,1,IRETOU)
  407. ENDIF
  408. IF(IERR.NE.0) RETURN
  409. JG=2
  410. SEGINI,MLREE1
  411. MLREE1.PROG(1)=XVAL1
  412. MLREE1.PROG(2)=XVAL2
  413. ELSE
  414. C On a lu un LISTREEL en 2eme argument
  415. MLREE2=IP2
  416. SEGACT,MLREE2
  417. JG1=MLREE2.PROG(/1)
  418. JG =JG1 + 1
  419. SEGINI,MLREE1
  420. MLREE1.PROG(1)=XVAL1
  421. IF(JG1 .GT. 0) THEN
  422. C Recopie en FORTRAN
  423. CALL OPTABJ(1,1,3,1,
  424. & MLREE2.PROG(1),MLREE2.PROG(1),MLREE1.PROG(2),
  425. & JG1 ,JG1 ,JG1,
  426. & 1,0,0.D0,IRETOU)
  427. ENDIF
  428. ENDIF
  429. ENDIF
  430. CTYP='LISTREEL'
  431. SEGACT,MLREE1*NOMOD
  432. IRETOU=MLREE1
  433. GOTO 100
  434.  
  435. *-- Création LISTENTI
  436. 218 CONTINUE
  437. IF(IRETOU.EQ.0) THEN
  438. * on n'a pas lu un LISTENTI
  439. CALL QUETYP(CTYP,1,IRETOU)
  440. IF(IERR.NE.0) RETURN
  441. IF(CTYP.NE.'ENTIER ') GOTO 999
  442. CALL LIRENT(IP2,1,IRETOU)
  443. IF(IERR.NE.0) RETURN
  444. CALL CRELEC(IP2)
  445. ENDIF
  446. CTYP='LISTENTI'
  447. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  448. CALL FUSLEC(IP1,IP2,IRETOU)
  449. GOTO 100
  450.  
  451. *-- Création EVOLUTION
  452. 219 CONTINUE
  453. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  454. CALL FUEVOL(IP1,IP2,IRETOU)
  455. GOTO 100
  456. *-- Création MODELE
  457. 220 CONTINUE
  458. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  459. CALL FUSMOD(IP1,IP2,IRETOU)
  460. GOTO 100
  461. *-- Création MCHAML
  462. 221 CONTINUE
  463. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  464. CALL ETMCHL(IP1,IP2,IRETOU)
  465. GOTO 100
  466.  
  467. *-- Création LISTMOTS
  468. 222 CONTINUE
  469. IF (IP1 .GT. 0 .AND. IP2 .GT. 0) THEN
  470. C LISTMOTS 'ET' LISTMOTS
  471. CALL FUSMOT(IP1,IP2,IRETOU)
  472.  
  473. ELSEIF(IP1 .GT. 0 .AND. IP2 .EQ. 0) THEN
  474. C LISTMOTS 'ET' MOT
  475. CALL QUETYP(CTYP2,0,IRETOU)
  476. IF(CTYP2 .EQ. 'MOT') THEN
  477. CALL LIRCHA(LEMOT1,1,IRET1)
  478. IF (IERR.NE.0) RETURN
  479. MLMOT1=IP1
  480. SEGACT,MLMOT1
  481. JGN=MLMOT1.MOTS(/1)
  482. JGM=MLMOT1.MOTS(/2)+1
  483. SEGINI,MLMOT2
  484. IRETOU=MLMOT2
  485. DO III=1,JGM-1
  486. MLMOT2.MOTS(III)=MLMOT1.MOTS(III)
  487. ENDDO
  488. MLMOT2.MOTS(JGM)=LEMOT1
  489. SEGDES,MLMOT1,MLMOT2
  490. ELSE
  491. GOTO 999
  492. ENDIF
  493.  
  494. ELSEIF(IP1 .EQ. 0 .AND. IP2 .GT. 0) THEN
  495. C MOT 'ET' LISTMOTS
  496. IF(CTYP .EQ. 'MOT') THEN
  497. CTYP = CTYP2
  498. MLMOT1=IP2
  499. SEGACT,MLMOT1
  500. JGN=MLMOT1.MOTS(/1)
  501. JGM=MLMOT1.MOTS(/2)+1
  502. SEGINI,MLMOT2
  503. IRETOU=MLMOT2
  504. MLMOT2.MOTS(1)=LEMOT1(1:JGN)
  505. DO III=2,JGM
  506. MLMOT2.MOTS(III)=MLMOT1.MOTS(III-1)
  507. ENDDO
  508. SEGDES,MLMOT1,MLMOT2
  509. ELSE
  510. GOTO 999
  511. ENDIF
  512. ENDIF
  513. GOTO 100
  514. *-- Création NUAGE
  515. 223 CONTINUE
  516. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  517. CALL FUSNUA(IP1,IP2,IRETOU)
  518. GOTO 100
  519. *-- Création MATRIK
  520. 224 CONTINUE
  521. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  522. CALL FUSMTK(IP1,IP2,IRETOU)
  523. GOTO 100
  524. *-- Création LISTCHPO
  525. 226 CONTINUE
  526. IF (CTYP.NE.'CHPOINT '.AND.CTYP.NE.'LISTCHPO') GOTO 999
  527. IF(IRETOU.EQ.0) THEN
  528. * on a lu des objets de types différents mais compatibles
  529. * (le cas de 2 champ-points est traité ailleurs)
  530. CALL MESLIR(-221)
  531. IF(CTYP.EQ.'CHPOINT ') THEN
  532. CALL LIROBJ('LISTCHPO',IP2,1,IRETAU)
  533. CALL ACTOBJ('LISTCHPO',IP2,1)
  534. ELSE
  535. CALL LIROBJ('CHPOINT ',IP2,1,IRETAU)
  536. CALL ACTOBJ('CHPOINT ',IP2,1)
  537. CALL CRLCHP(IP2)
  538. ENDIF
  539. IF(IERR.NE.0) RETURN
  540. ENDIF
  541. CTYP='LISTCHPO'
  542. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  543. CALL FUSSUI(IP1,IP2,IRETOU)
  544. GOTO 100
  545. *-- Création ANNOTATI
  546. 227 CONTINUE
  547. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  548. MANNO1=IP1
  549. MANNO2=IP2
  550. SEGACT,MANNO1,MANNO2
  551. NBANN1=MANNO1.ICLAS(/1)
  552. NBANN2=MANNO2.ICLAS(/1)
  553. NBANNO=NBANN1+NBANN2
  554. SEGINI,MANNO3
  555. DO K1=1,NBANN1
  556. MANNO3.ICLAS(K1) = MANNO1.ICLAS(K1)
  557. MANNO3.ISEGT(K1) = MANNO1.ISEGT(K1)
  558. ENDDO
  559. DO K2=1,NBANN2
  560. MANNO3.ICLAS(NBANN1+K2) = MANNO2.ICLAS(K2)
  561. MANNO3.ISEGT(NBANN1+K2) = MANNO2.ISEGT(K2)
  562. ENDDO
  563. IRETOU=MANNO3
  564. GOTO 100
  565.  
  566. * Sortie sans problème, écriture résultat
  567. 100 CONTINUE
  568. CALL ACTOBJ(CTYP,IRETOU,1)
  569. CALL ECROBJ(CTYP,IRETOU)
  570. RETURN
  571.  
  572. * Fusion de chaines, limitation à 512 caractères
  573. 225 CONTINUE
  574. IRET=IRET1+IRET2
  575. IF(IRET.GT.512) THEN
  576. CALL ERREUR(1110)
  577. RETURN
  578. ENDIF
  579. LEMOT(1:IRET1) = LEMOT1(1:IRET1)
  580. LEMOT(IRET1+1:IRET) = LEMOT2(1:IRET2)
  581. CALL ECRCHA(LEMOT(1:IRET))
  582. RETURN
  583.  
  584.  
  585. * ================
  586. * Deuxième syntaxe
  587. * ================
  588. * Fusion de tous les indices d'une table
  589.  
  590. 1000 CONTINUE
  591. MTABLE=IP1
  592. IF (IRETOU.EQ.1) THEN
  593. * ET DE TABLES ESCLAVE
  594. * WRITE(IOIMP,*) ' TABLE ESCLAVE DANS ET'
  595. * IF (LODESL) THEN
  596. * WRITE(IOIMP,*) ' LODESL REMIS À FAUX DANS PRFUSE '
  597. * LODESL=.FALSE.
  598. * CALL ABORT
  599. * ENDIF
  600. CALL ACCTAB(MTABLE,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,0,
  601. > 'MOT',ID3,RR1,CTYP,IR1,ID2)
  602. IF (CTYP.NE.'ESCLAVE') THEN
  603. * Donnez une TABLE de sous-type %m1:8
  604. MOTERR(1:8)='ESCLAVE'
  605. CALL ERREUR(-173)
  606. * Le sous-type de la table est incorrect
  607. CALL ERREUR(648)
  608. RETURN
  609. ENDIF
  610. SEGACT MTABLE
  611. ML=MLOTAB
  612. * L'INDICE 1 EST LE SOUSTYPE, l'INDICE 2 EST LE CREATEUR
  613. IND=MTABII(3)
  614. CTYP=' '
  615. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  616. > CTYP,ID3,RR1,TYPRET,IR1,ID1)
  617. IRETOU=ID1
  618. IF (CTYP.EQ.'POINT') THEN
  619. NBNN=1
  620. NBSOUS=0
  621. NBREF=0
  622. NBELEM=ML-2
  623. SEGINI MELEME
  624. ITYPEL=1
  625. NUM(1,1)=ID1
  626. ICOLOR(1)=IDCOUL
  627. DO I=4,ML
  628. IND=MTABII(I)
  629. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  630. > CTYP,ID3,RR1,' ',IR1,ID2)
  631. IF (IERR.NE.0) RETURN
  632. NUM(1,I-2)=ID2
  633. ICOLOR(I-2)=IDCOUL
  634. ENDDO
  635. IRETOU=MELEME
  636. CTYP='MAILLAGE'
  637. ELSEIF (CTYP.EQ.'FLOTTANT') THEN
  638. JG=ML-2
  639. SEGINI,MLREE1
  640. MLREE1.PROG(1)=RR1
  641. DO I=4,ML
  642. IND=MTABII(I)
  643. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  644. > CTYP,ID3,RR1,' ',IR1,ID2)
  645. IF (IERR.NE.0) RETURN
  646. MLREE1.PROG(I-2)=RR1
  647. ENDDO
  648. IRETOU= MLREE1
  649. CTYP ='LISTREEL'
  650. ELSEIF (CTYP.EQ.'ENTIER') THEN
  651. JG=ML-2
  652. SEGINI,MLENT1
  653. MLENT1.LECT(1)=ID3
  654. DO I=4,ML
  655. IND=MTABII(I)
  656. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  657. > CTYP,ID3,RR1,' ',IR1,ID2)
  658. IF (IERR.NE.0) RETURN
  659. MLENT1.LECT(I-2)=ID3
  660. ENDDO
  661. IRETOU= MLENT1
  662. CTYP ='LISTENTI'
  663. ELSEIF (CTYP.EQ.'MAILLAGE') THEN
  664. DO I=4,ML
  665. IND=MTABII(I)
  666. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  667. > CTYP,ID3,RR1,' ',IR1,ID2)
  668. IF (IERR.NE.0) RETURN
  669. CALL FUSE(ID1,ID2,IRETOU,LTELQ)
  670. ID1=IRETOU
  671. ENDDO
  672. ELSEIF (CTYP.EQ.'MCHAML') THEN
  673. DO I=4,ML
  674. IND=MTABII(I)
  675. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  676. > CTYP,ID3,RR1,' ',IR1,ID2)
  677. IF (IERR.NE.0) RETURN
  678. CALL FUSCHL(ID1,ID2,IRETOU)
  679. ID1=IRETOU
  680. ENDDO
  681. ELSEIF (CTYP.EQ.'CHPOINT ') THEN
  682. DO I=4,ML
  683. IND=MTABII(I)
  684. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  685. > CTYP,ID3,RR1,' ',IR1,ID2)
  686. IF (IERR.NE.0) RETURN
  687. CALL FUCHPO(ID1,ID2,IRETOU)
  688. IF (IERR.NE.0) RETURN
  689. ID1=IRETOU
  690. ENDDO
  691. ELSEIF (CTYP.EQ.'RIGIDITE') THEN
  692. DO I=4,ML
  693. IND=MTABII(I)
  694. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  695. > CTYP,ID3,RR1,' ',IR1,ID2)
  696. IF (IERR.NE.0) RETURN
  697. CALL FUSRIG(ID1,ID2,IRETOU)
  698. IF (IERR.NE.0) RETURN
  699. ID1=IRETOU
  700. ENDDO
  701. ELSEIF (CTYP.EQ.'MATRIK ') THEN
  702. DO I=4,ML
  703. IND=MTABII(I)
  704. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  705. > CTYP,ID3,RR1,' ',IR1,ID2)
  706. IF (IERR.NE.0) RETURN
  707. CALL FUSMTK(ID1,ID2,IRETOU)
  708. IF (IERR.NE.0) RETURN
  709. ID1=IRETOU
  710. ENDDO
  711. ELSEIF (CTYP.EQ.'MMODEL') THEN
  712. DO I=4,ML
  713. IND=MTABII(I)
  714. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  715. > CTYP,ID3,RR1,' ',IR1,ID2)
  716. IF (IERR.NE.0) RETURN
  717. CALL FUSMOD(ID1,ID2,IRETOU)
  718. IF (IERR.NE.0) RETURN
  719. ID1=IRETOU
  720. ENDDO
  721. ELSEIF (CTYP.EQ.'LISTREEL') THEN
  722. DO I=4,ML
  723. IND=MTABII(I)
  724. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  725. > CTYP,ID3,RR1,' ',IR1,ID2)
  726. IF (IERR.NE.0) RETURN
  727. CALL FUSPRO(ID1,ID2,IRETOU)
  728. IF (IERR.NE.0) RETURN
  729. ID1=IRETOU
  730. ENDDO
  731. ELSEIF (CTYP.EQ.'LISTENTI') THEN
  732. DO I=4,ML
  733. IND=MTABII(I)
  734. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  735. > CTYP,ID3,RR1,' ',IR1,ID2)
  736. IF (IERR.NE.0) RETURN
  737. CALL FUSLEC(ID1,ID2,IRETOU)
  738. IF (IERR.NE.0) RETURN
  739. ID1=IRETOU
  740. ENDDO
  741. ELSE
  742. * On ne veut pas d'objet de type %m1:8
  743. MOTERR(1:8)=CTYP
  744. CALL ERREUR(39)
  745. RETURN
  746. ENDIF
  747. SEGDES,MTABLE
  748. GOTO 100
  749. ENDIF
  750.  
  751.  
  752. * =================
  753. * Troisième syntaxe
  754. * =================
  755. * FUSION TABLE DE MODES
  756.  
  757. 2000 CONTINUE
  758.  
  759. CALL CRTABL(IPTAB2)
  760. IPOUT = IPTAB2
  761. IL = 0
  762. IF (LEMOT.EQ.'LIAISONS_STATIQUES') THEN
  763. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,IP0,
  764. & 'MOT',0,0.0D0,'LIAISONS_STATIQUES',.TRUE.,IP1)
  765. ELSE
  766. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,IP0,
  767. & 'MOT',0,0.0D0,'BASE_MODALE',.TRUE.,IP1)
  768. CALL CRTABL(IPTAB3)
  769. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MODES',.TRUE.,IP0,
  770. & 'TABLE',0,0.0D0,' ',.TRUE.,IPTAB3)
  771. IPTAB2 = IPTAB3
  772. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,IP0,
  773. & 'MOT',0,0.0D0,'BASE_DE_MODES',.TRUE.,IP1)
  774. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MAILLAGE',.TRUE.,IP0,
  775. & 'MOT',0,0.0D0,'MAILLAGE',.TRUE.,IP1)
  776. cbp : plutot qu'ecrire le mot MAILLAGE(???), on fusionne les 2 maillages
  777. CALL ACCTAB(MTABLE,'MOT',0,0.D0,'MODES',.TRUE.,0,
  778. > 'TABLE',ID3,RR1,' ',.TRUE.,IP1)
  779. IF (IERR.NE.0) RETURN
  780. MTABLE = IP1
  781. CALL ACCTAB(IP1,'MOT',0,0.D0,'MAILLAGE',.TRUE.,0,
  782. > 'MAILLAGE',ID3,RR1,' ',.TRUE.,IPT1)
  783. IF (IERR.NE.0) RETURN
  784. ENDIF
  785.  
  786. c ---copie de la IKO ieme table (IKO=1,2)
  787. IKO = 0
  788. 2100 IKO = IKO + 1
  789. SEGACT MTABLE
  790.  
  791. c ---boucle sur les modes ou les solutions statiques
  792. IF (LEMOT.EQ.'LIAISONS_STATIQUES') THEN
  793. IMA = MLOTAB - 1
  794. ELSE
  795. IMA = MLOTAB - 2
  796. ENDIF
  797. IM = 0
  798. 2160 IM = IM + 1
  799. CTYP=' '
  800. CALL ACCTAB(MTABLE,'ENTIER',IM,0.D0,' ',.TRUE.,0,
  801. c > 'TABLE',ID3,RR1,' ',.TRUE.,ITMOD)
  802. > CTYP,ID3,RR1,' ',.TRUE.,ITMOD)
  803. IF(CTYP.NE.'TABLE') GOTO 2161
  804. IF (ITMOD.GT.0) THEN
  805. IL = IL + 1
  806. CALL ECCTAB(IPTAB2,'ENTIER',IL,0.0D0,' ',.TRUE.,IP0,
  807. & 'TABLE',0,0.0D0,' ',.TRUE.,ITMOD)
  808. ENDIF
  809. 2161 CONTINUE
  810. IF (IM.LT.IMA) GOTO 2160
  811. c ---fin de boucle sur les modes ou les solutions statiques
  812.  
  813. SEGDES MTABLE
  814. IF (IKO.EQ.1) THEN
  815. IF (LEMOT.EQ.'LIAISONS_STATIQUES') THEN
  816. CALL LIRTAB('LIAISONS_STATIQUES',IP1,0,IRETOU)
  817. IF (IRETOU.EQ.0) GOTO 2300
  818. MTABLE = IP1
  819. ELSE
  820. CALL LIRTAB('BASE_MODALE',IP1,0,IRETOU)
  821. IF (IRETOU.EQ.0) GOTO 2300
  822. CALL ACCTAB(IP1,'MOT',0,0.D0,'MODES',.TRUE.,0,
  823. > 'TABLE',ID3,RR1,' ',.TRUE.,MTABLE)
  824. c fusion des 2 maillages
  825. CALL ACCTAB(MTABLE,'MOT',0,0.D0,'MAILLAGE',.TRUE.,0,
  826. > 'MAILLAGE',ID3,RR1,' ',.TRUE.,IPT2)
  827. CALL FUSE(IPT1,IPT2,IPT3,.FALSE.)
  828. CALL UNIQMA(IPT3,NBDIF)
  829. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MAILLAGE',.TRUE.,IP0,
  830. & 'MAILLAGE',0,0.0D0,' ',.TRUE.,IPT3)
  831. ENDIF
  832. GOTO 2100
  833. ENDIF
  834. c ---fin de boucle sur les tables IKO=1,2
  835.  
  836. 2300 CALL ECROBJ('TABLE ',ipout)
  837. RETURN
  838.  
  839.  
  840. * =========
  841. * ERREUR 39
  842. * =========
  843. 999 CONTINUE
  844. * On ne veut pas d'objet de type %m1:8
  845. MOTERR(1:8)=CTYP
  846. CALL ERREUR(39)
  847. END
  848.  
  849.  
  850.  
  851.  

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