Télécharger prfuse.eso

Retour à la liste

Numérotation des lignes :

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

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