Télécharger prfuse.eso

Retour à la liste

Numérotation des lignes :

  1. C PRFUSE SOURCE BP208322 19/04/03 21:15:24 10175
  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. -INC SMLREEL
  33.  
  34. EXTERNAL LONG
  35.  
  36. LOGICAL IR1,IR2,IR3,LTELQ
  37. CHARACTER*(8) CTYP,CTYP2,ICHAT,TYPRET,TYPRE1
  38. CHARACTER*(72) LEMOT,LEMOT1,LEMOT2
  39. REAL*8 XVAL
  40. CHARACTER*4 LISTMO(1)
  41. DATA LISTMO / 'TELQ' /
  42.  
  43. IP0 = 0
  44. IP1 = 0
  45. IP2 = 0
  46.  
  47. * Recherche préalable du mot-clef 'TELQUEL' éventuel
  48. CALL LIRMOT(LISTMO,1,IRE2,0)
  49. IF (IERR.NE.0) RETURN
  50. LTELQ = (IRE2.EQ.1)
  51.  
  52. * Lecture du premier objet
  53. * ------------------------
  54. CALL MESLIR(-225)
  55. CALL QUETYP(CTYP,0,IRETOU)
  56. IF(IRETOU.EQ.0) THEN
  57. * Cet opérateur a encore besoin d'un opérande.
  58. CALL ERREUR (533)
  59. RETURN
  60. ENDIF
  61.  
  62. IF(CTYP.EQ.'LOGIQUE ') THEN
  63. CALL MESLIR(-225)
  64. CALL LIRLOG(IR1,1,IRETOU)
  65. CALL MESLIR(-223)
  66. CALL LIRLOG(IR2,1,IRETOU)
  67. IF(IERR.NE.0) RETURN
  68. GOTO 213
  69.  
  70. ELSE IF(CTYP.EQ.'MOT ') THEN
  71. CALL LIRCHA(LEMOT1,1,IRET1)
  72. IF (IERR.NE.0) RETURN
  73.  
  74. CALL QUETYP(CTYP2,0,IRETOU)
  75. IF(IRETOU.EQ.0) THEN
  76. * Cet opérateur a encore besoin d'un opérande.
  77. CALL ERREUR (533)
  78. RETURN
  79. ENDIF
  80. IF(CTYP2 .EQ. 'LISTMOTS') THEN
  81.  
  82. CALL LIROBJ(CTYP2,IP2,ICODE,IRETOU)
  83. IF(IERR.NE.0) RETURN
  84. GOTO 222
  85.  
  86. ELSE
  87. CALL LIRCHA(LEMOT2,1,IRET2)
  88. IF( IERR.NE.0) RETURN
  89. IF (LTELQ) THEN
  90. * Concaténation avec respect des espaces avant et après
  91. ELSE
  92. * Suppressions des espaces en fin de mot
  93. IRET1=LONG(LEMOT1)
  94. IRET2=LONG(LEMOT2)
  95. ENDIF
  96. GOTO 225
  97. ENDIF
  98.  
  99. ELSE IF(CTYP.EQ.'FLOTTANT') THEN
  100. CALL LIRREE(XVAL1,1,IRETOU)
  101. IF(IERR.NE.0) RETURN
  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. XVAL1=FLOAT(IP1)
  115. IP1=0
  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. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  286. CALL FUCHPO(IP1,IP2,IRETOU)
  287. CALL ACTOBJ('CHPOINT ',IRETOU,1)
  288. GOTO 100
  289. ELSE
  290. *PM autrement, on peut obtenir une liste de chpoints
  291. CALL CRLCHP(IP1)
  292. GOTO 226
  293. ENDIF
  294.  
  295. *-- Création RIGIDITE
  296. 4 CONTINUE
  297. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  298. CALL FUSRIG(IP1,IP2,IRETOU)
  299. GOTO 100
  300. *-- Création STRUCTURE
  301. 205 CONTINUE
  302. CALL FUSTRU(IP1,IP2,IRETOU)
  303. GOTO 100
  304. *-- Création SOLUTION
  305. 206 CONTINUE
  306. CALL FUSOLU(IP1,IP2,IRETOU)
  307. GOTO 100
  308. *-- Création ATTACHE
  309. 207 CONTINUE
  310. CALL FUSATT(IP1,IP2,IRETOU)
  311. GOTO 100
  312. *-- Création ELEMSTRU
  313. 210 CONTINUE
  314. CALL FUSELS(IP1,IP2,IRETOU)
  315. GOTO 100
  316. *-- Création BLOQSTRU
  317. 211 CONTINUE
  318. CALL FUSCLS(IP1,IP2,IRETOU)
  319. GOTO 100
  320. *-- Création BASE MODALE
  321. 212 CONTINUE
  322. CALL FUSBAS(IP1,IP2,IRETOU)
  323. GOTO 100
  324. *-- Opération LOGIQUE
  325. 213 CONTINUE
  326. IR3=IR1.AND.IR2
  327. CALL ECRLOG(IR3)
  328. RETURN
  329. *-- Création DEFORMEE
  330. 214 CONTINUE
  331. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  332. CALL FUSDEF(IP1,IP2,IRETOU)
  333. GOTO 100
  334. *-- Création VECTEUR
  335. 215 CONTINUE
  336. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  337. CALL FUSVEC (IP1,IP2,IRETOU)
  338. GOTO 100
  339. *-- Création CHARGEMENT
  340. 216 CONTINUE
  341. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  342. CALL FUSCHA(IP1,IP2,IRETOU)
  343. GOTO 100
  344.  
  345. *-- Création LISTREEL
  346. 217 CONTINUE
  347. IF(IP1 .NE. 0)THEN
  348. C On a lu un LISTREEL en 1er argument
  349. IF(IRETOU.EQ.0) THEN
  350. C On n'a pas lu un LISTREEL en 2eme argument
  351. CALL QUETYP(CTYP,1,IRETOU)
  352. IF(IERR.NE.0) RETURN
  353. IF((CTYP.NE.'ENTIER ').AND.(CTYP.NE.'FLOTTANT')) GOTO 999
  354. C On a lu des objets de types différents mais compatibles
  355. IF (CTYP.EQ.'ENTIER ') THEN
  356. CALL LIRENT(IVAL2,1,IRETOU)
  357. XVAL2=FLOAT(IVAL2)
  358. ELSE
  359. CALL LIRREE(XVAL2,1,IRETOU)
  360. ENDIF
  361. IF(IERR.NE.0) RETURN
  362.  
  363. MLREE2=IP1
  364. SEGACT,MLREE2
  365. JG1=MLREE2.PROG(/1)
  366. JG =JG1 + 1
  367. SEGINI,MLREE1
  368. MLREE1.PROG(JG)=XVAL2
  369. IF(JG1 .GT. 0)THEN
  370. C Recopie en FORTRAN
  371. CALL OPTABJ(1,1,3,1,
  372. & MLREE2.PROG(1),MLREE2.PROG(1),MLREE1.PROG(1),
  373. & JG1 ,JG1 ,JG1,
  374. & 1,0,0.D0,IRETOU)
  375. ENDIF
  376. ELSE
  377. C On a lu un LISTREEL en 2eme argument
  378. CALL FUSPRO(IP1,IP2,IRETOU)
  379. MLREE1=IRETOU
  380. ENDIF
  381. ELSE
  382. C On n'a pas lu un LISTREEL en 1er argument
  383. IF(IRETOU.EQ.0) THEN
  384. C On n'a pas lu un LISTREEL en 2eme argument
  385. CALL QUETYP(CTYP,1,IRETOU)
  386. IF(IERR.NE.0) RETURN
  387. IF((CTYP.NE.'ENTIER ').AND.(CTYP.NE.'FLOTTANT')) GOTO 999
  388. C On a lu des objets de types différents mais compatibles
  389. IF (CTYP.EQ.'ENTIER ') THEN
  390. CALL LIRENT(IVAL2,1,IRETOU)
  391. XVAL2=FLOAT(IVAL2)
  392. ELSE
  393. CALL LIRREE(XVAL2,1,IRETOU)
  394. ENDIF
  395. IF(IERR.NE.0) RETURN
  396. JG=2
  397. SEGINI,MLREE1
  398. MLREE1.PROG(1)=XVAL1
  399. MLREE1.PROG(2)=XVAL2
  400. ELSE
  401. C On a lu un LISTREEL en 2eme argument
  402. MLREE2=IP2
  403. SEGACT,MLREE2
  404. JG1=MLREE2.PROG(/1)
  405. JG =JG1 + 1
  406. SEGINI,MLREE1
  407. MLREE1.PROG(1)=XVAL1
  408. IF(JG1 .GT. 0) THEN
  409. C Recopie en FORTRAN
  410. CALL OPTABJ(1,1,3,1,
  411. & MLREE2.PROG(1),MLREE2.PROG(1),MLREE1.PROG(2),
  412. & JG1 ,JG1 ,JG1,
  413. & 1,0,0.D0,IRETOU)
  414. ENDIF
  415. ENDIF
  416. ENDIF
  417. CTYP='LISTREEL'
  418. SEGACT,MLREE1*NOMOD
  419. IRETOU=MLREE1
  420. GOTO 100
  421.  
  422. *-- Création LISTENTI
  423. 218 CONTINUE
  424. IF(IRETOU.EQ.0) THEN
  425. * on n'a pas lu un LISTENTI
  426. CALL QUETYP(CTYP,1,IRETOU)
  427. IF(IERR.NE.0) RETURN
  428. IF(CTYP.NE.'ENTIER ') GOTO 999
  429. CALL LIRENT(IP2,1,IRETOU)
  430. IF(IERR.NE.0) RETURN
  431. CALL CRELEC(IP2)
  432. ENDIF
  433. CTYP='LISTENTI'
  434. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  435. CALL FUSLEC(IP1,IP2,IRETOU)
  436. GOTO 100
  437.  
  438. *-- Création EVOLUTION
  439. 219 CONTINUE
  440. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  441. CALL FUEVOL(IP1,IP2,IRETOU)
  442. GOTO 100
  443. *-- Création MODELE
  444. 220 CONTINUE
  445. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  446. CALL FUSMOD(IP1,IP2,IRETOU)
  447. GOTO 100
  448. *-- Création MCHAML
  449. 221 CONTINUE
  450. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  451. CALL FUSCHL(IP1,IP2,IRETOU)
  452. GOTO 100
  453.  
  454. *-- Création LISTMOTS
  455. 222 CONTINUE
  456. IF (IP1 .GT. 0 .AND. IP2 .GT. 0) THEN
  457. C LISTMOTS 'ET' LISTMOTS
  458. CALL FUSMOT(IP1,IP2,IRETOU)
  459.  
  460. ELSEIF(IP1 .GT. 0 .AND. IP2 .EQ. 0) THEN
  461. C LISTMOTS 'ET' MOT
  462. CALL QUETYP(CTYP2,0,IRETOU)
  463. IF(CTYP2 .EQ. 'MOT') THEN
  464. CALL LIRCHA(LEMOT1,1,IRET1)
  465. IF (IERR.NE.0) RETURN
  466. MLMOT1=IP1
  467. SEGACT,MLMOT1
  468. JGN=MLMOT1.MOTS(/1)
  469. JGM=MLMOT1.MOTS(/2)+1
  470. SEGINI,MLMOT2
  471. IRETOU=MLMOT2
  472. DO III=1,JGM-1
  473. MLMOT2.MOTS(III)=MLMOT1.MOTS(III)
  474. ENDDO
  475. MLMOT2.MOTS(JGM)=LEMOT1
  476. SEGDES,MLMOT1,MLMOT2
  477. ELSE
  478. GOTO 999
  479. ENDIF
  480.  
  481. ELSEIF(IP1 .EQ. 0 .AND. IP2 .GT. 0) THEN
  482. C MOT 'ET' LISTMOTS
  483. IF(CTYP .EQ. 'MOT') THEN
  484. CTYP = CTYP2
  485. MLMOT1=IP2
  486. SEGACT,MLMOT1
  487. JGN=MLMOT1.MOTS(/1)
  488. JGM=MLMOT1.MOTS(/2)+1
  489. SEGINI,MLMOT2
  490. IRETOU=MLMOT2
  491. MLMOT2.MOTS(1)=LEMOT1(1:JGN)
  492. DO III=2,JGM
  493. MLMOT2.MOTS(III)=MLMOT1.MOTS(III-1)
  494. ENDDO
  495. SEGDES,MLMOT1,MLMOT2
  496. ELSE
  497. GOTO 999
  498. ENDIF
  499. ENDIF
  500. GOTO 100
  501. *-- Création NUAGE
  502. 223 CONTINUE
  503. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  504. CALL FUSNUA(IP1,IP2,IRETOU)
  505. GOTO 100
  506. *-- Création MATRIK
  507. 224 CONTINUE
  508. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  509. CALL FUSMTK(IP1,IP2,IRETOU)
  510. GOTO 100
  511. *-- Création LISTCHPO
  512. 226 CONTINUE
  513. IF (CTYP.NE.'CHPOINT '.AND.CTYP.NE.'LISTCHPO') GOTO 999
  514. IF(IRETOU.EQ.0) THEN
  515. * on a lu des objets de types différents mais compatibles
  516. * (le cas de 2 champ-points est traité ailleurs)
  517. CALL MESLIR(-221)
  518. IF(CTYP.EQ.'CHPOINT ') THEN
  519. CALL LIROBJ('LISTCHPO',IP2,1,IRETAU)
  520. ELSE
  521. CALL LIROBJ('CHPOINT ',IP2,1,IRETAU)
  522. CALL CRLCHP(IP2)
  523. ENDIF
  524. IF(IERR.NE.0) RETURN
  525. ENDIF
  526. CTYP='LISTCHPO'
  527. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  528. CALL FUSSUI(IP1,IP2,IRETOU)
  529. GOTO 100
  530.  
  531. * Sortie sans problème, écriture résultat
  532. 100 CONTINUE
  533. IF(IERR.NE.0) RETURN
  534. CALL ECROBJ(CTYP,IRETOU)
  535. RETURN
  536.  
  537. * Fusion de chaines, limitation à 72 caractères, contrairement à
  538. * l'opérateur CHAINE
  539. 225 CONTINUE
  540. IRET=IRET1+IRET2
  541. IF(IRET.GT.72) THEN
  542. * Un titre ou un texte ne peut avoir plus de 72 caractères
  543. CALL ERREUR(425)
  544. RETURN
  545. ENDIF
  546. LEMOT(1:IRET1) = LEMOT1(1:IRET1)
  547. LEMOT(IRET1+1:IRET) = LEMOT2(1:IRET2)
  548. CALL ECRCHA(LEMOT(1:IRET))
  549. RETURN
  550.  
  551.  
  552. * ================
  553. * Deuxième syntaxe
  554. * ================
  555. * Fusion de tous les indices d'une table
  556.  
  557. 1000 CONTINUE
  558. MTABLE=IP1
  559. IF (IRETOU.EQ.1) THEN
  560. * ET DE TABLES ESCLAVE
  561. * WRITE(IOIMP,*) ' TABLE ESCLAVE DANS ET'
  562. * IF (LODESL) THEN
  563. * WRITE(IOIMP,*) ' LODESL REMIS À FAUX DANS PRFUSE '
  564. * LODESL=.FALSE.
  565. * CALL ABORT
  566. * ENDIF
  567. CALL ACCTAB(MTABLE,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,0,
  568. > 'MOT',ID3,RR1,CTYP,IR1,ID2)
  569. IF (CTYP.NE.'ESCLAVE') THEN
  570. * Donnez une TABLE de sous-type %m1:8
  571. MOTERR(1:8)='ESCLAVE'
  572. CALL ERREUR(-173)
  573. * Le sous-type de la table est incorrect
  574. CALL ERREUR(648)
  575. RETURN
  576. ENDIF
  577. SEGACT MTABLE
  578. ML=MLOTAB
  579. * L'INDICE 1 EST LE SOUS TYPE
  580. IND=MTABII(3)
  581. CTYP=' '
  582. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  583. > CTYP,ID3,RR1,TYPRET,IR1,ID1)
  584. IRETOU=ID1
  585. IF (CTYP.EQ.'POINT') THEN
  586. NBNN=1
  587. NBSOUS=0
  588. NBREF=0
  589. NBELEM=ML-2
  590. SEGINI MELEME
  591. ITYPEL=1
  592. NUM(1,1)=ID1
  593. ICOLOR(1)=IDCOUL
  594. DO I=4,ML
  595. SEGACT MTABLE
  596. IND=MTABII(I)
  597. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  598. > CTYP,ID3,RR1,' ',IR1,ID2)
  599. IF (IERR.NE.0) RETURN
  600. NUM(1,I-2)=ID2
  601. ICOLOR(I-2)=IDCOUL
  602. ENDDO
  603. SEGDES MELEME
  604. IRETOU=MELEME
  605. CTYP='MAILLAGE'
  606. ELSEIF (CTYP.EQ.'MAILLAGE') THEN
  607. DO I=4,ML
  608. SEGACT MTABLE
  609. IND=MTABII(I)
  610. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  611. > CTYP,ID3,RR1,' ',IR1,ID2)
  612. IF (IERR.NE.0) RETURN
  613. CALL FUSE(ID1,ID2,IRETOU,LTELQ)
  614. ID1=IRETOU
  615. ENDDO
  616. ELSEIF (CTYP.EQ.'MCHAML') THEN
  617. DO I=4,ML
  618. SEGACT MTABLE
  619. IND=MTABII(I)
  620. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  621. > CTYP,ID3,RR1,' ',IR1,ID2)
  622. IF (IERR.NE.0) RETURN
  623. CALL FUSCHL(ID1,ID2,IRETOU)
  624. ID1=IRETOU
  625. ENDDO
  626. ELSEIF (CTYP.EQ.'CHPOINT ') THEN
  627. DO I=4,ML
  628. SEGACT MTABLE
  629. IND=MTABII(I)
  630. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  631. > CTYP,ID3,RR1,' ',IR1,ID2)
  632. IF (IERR.NE.0) RETURN
  633. CALL FUCHPO(ID1,ID2,IRETOU)
  634. IF (IERR.NE.0) RETURN
  635. ID1=IRETOU
  636. ENDDO
  637. ELSEIF (CTYP.EQ.'RIGIDITE') THEN
  638. DO I=4,ML
  639. SEGACT MTABLE
  640. IND=MTABII(I)
  641. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  642. > CTYP,ID3,RR1,' ',IR1,ID2)
  643. IF (IERR.NE.0) RETURN
  644. CALL FUSRIG(ID1,ID2,IRETOU)
  645. IF (IERR.NE.0) RETURN
  646. ID1=IRETOU
  647. ENDDO
  648. ELSEIF (CTYP.EQ.'MATRIK ') THEN
  649. DO I=4,ML
  650. SEGACT MTABLE
  651. IND=MTABII(I)
  652. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  653. > CTYP,ID3,RR1,' ',IR1,ID2)
  654. IF (IERR.NE.0) RETURN
  655. CALL FUSMTK(ID1,ID2,IRETOU)
  656. IF (IERR.NE.0) RETURN
  657. ID1=IRETOU
  658. ENDDO
  659. ELSEIF (CTYP.EQ.'MMODEL') THEN
  660. DO I=4,ML
  661. SEGACT MTABLE
  662. IND=MTABII(I)
  663. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  664. > CTYP,ID3,RR1,' ',IR1,ID2)
  665. IF (IERR.NE.0) RETURN
  666. CALL FUSMOD(ID1,ID2,IRETOU)
  667. IF (IERR.NE.0) RETURN
  668. ID1=IRETOU
  669. ENDDO
  670. ELSEIF (CTYP.EQ.'LISTREEL') THEN
  671. DO I=4,ML
  672. SEGACT MTABLE
  673. IND=MTABII(I)
  674. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  675. > CTYP,ID3,RR1,' ',IR1,ID2)
  676. IF (IERR.NE.0) RETURN
  677. CALL FUSPRO(ID1,ID2,IRETOU)
  678. IF (IERR.NE.0) RETURN
  679. ID1=IRETOU
  680. ENDDO
  681. ELSEIF (CTYP.EQ.'LISTENTI') THEN
  682. DO I=4,ML
  683. SEGACT MTABLE
  684. IND=MTABII(I)
  685. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  686. > CTYP,ID3,RR1,' ',IR1,ID2)
  687. IF (IERR.NE.0) RETURN
  688. CALL FUSLEC(ID1,ID2,IRETOU)
  689. IF (IERR.NE.0) RETURN
  690. ID1=IRETOU
  691. ENDDO
  692. ELSE
  693. * On ne veut pas d'objet de type %m1:8
  694. MOTERR(1:8)=CTYP
  695. CALL ERREUR(39)
  696. RETURN
  697. ENDIF
  698. SEGDES MTABLE
  699. GOTO 100
  700. ENDIF
  701.  
  702.  
  703. * =================
  704. * Troisième syntaxe
  705. * =================
  706. * FUSION TABLE DE MODES
  707.  
  708. 2000 CONTINUE
  709.  
  710. CALL CRTABL(IPTAB2)
  711. IPOUT = IPTAB2
  712. IL = 0
  713. IF (LEMOT.EQ.'LIAISONS_STATIQUES') THEN
  714. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,IP0,
  715. & 'MOT',0,0.0D0,'LIAISONS_STATIQUES',.TRUE.,IP1)
  716. ELSE
  717. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,IP0,
  718. & 'MOT',0,0.0D0,'BASE_MODALE',.TRUE.,IP1)
  719. CALL CRTABL(IPTAB3)
  720. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MODES',.TRUE.,IP0,
  721. & 'TABLE',0,0.0D0,' ',.TRUE.,IPTAB3)
  722. IPTAB2 = IPTAB3
  723. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,IP0,
  724. & 'MOT',0,0.0D0,'BASE_DE_MODES',.TRUE.,IP1)
  725. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MAILLAGE',.TRUE.,IP0,
  726. & 'MOT',0,0.0D0,'MAILLAGE',.TRUE.,IP1)
  727. cbp : plutot qu'ecrire le mot MAILLAGE(???), on fusionne les 2 maillages
  728. CALL ACCTAB(MTABLE,'MOT',0,0.D0,'MODES',.TRUE.,0,
  729. > 'TABLE',ID3,RR1,' ',.TRUE.,IP1)
  730. IF (IERR.NE.0) RETURN
  731. MTABLE = IP1
  732. CALL ACCTAB(IP1,'MOT',0,0.D0,'MAILLAGE',.TRUE.,0,
  733. > 'MAILLAGE',ID3,RR1,' ',.TRUE.,IPT1)
  734. IF (IERR.NE.0) RETURN
  735. ENDIF
  736.  
  737. c ---copie de la IKO ieme table (IKO=1,2)
  738. IKO = 0
  739. 2100 IKO = IKO + 1
  740. SEGACT MTABLE
  741.  
  742. c ---boucle sur les modes ou les solutions statiques
  743. IF (LEMOT.EQ.'LIAISONS_STATIQUES') THEN
  744. IMA = MLOTAB - 1
  745. ELSE
  746. IMA = MLOTAB - 2
  747. ENDIF
  748. IM = 0
  749. 2160 IM = IM + 1
  750. CTYP=' '
  751. CALL ACCTAB(MTABLE,'ENTIER',IM,0.D0,' ',.TRUE.,0,
  752. c > 'TABLE',ID3,RR1,' ',.TRUE.,ITMOD)
  753. > CTYP,ID3,RR1,' ',.TRUE.,ITMOD)
  754. IF(CTYP.NE.'TABLE') GOTO 2161
  755. IF (ITMOD.GT.0) THEN
  756. IL = IL + 1
  757. CALL ECCTAB(IPTAB2,'ENTIER',IL,0.0D0,' ',.TRUE.,IP0,
  758. & 'TABLE',0,0.0D0,' ',.TRUE.,ITMOD)
  759. ENDIF
  760. 2161 CONTINUE
  761. IF (IM.LT.IMA) GOTO 2160
  762. c ---fin de boucle sur les modes ou les solutions statiques
  763.  
  764. SEGDES MTABLE
  765. IF (IKO.EQ.1) THEN
  766. IF (LEMOT.EQ.'LIAISONS_STATIQUES') THEN
  767. CALL LIRTAB('LIAISONS_STATIQUES',IP1,0,IRETOU)
  768. IF (IRETOU.EQ.0) GOTO 2300
  769. MTABLE = IP1
  770. ELSE
  771. CALL LIRTAB('BASE_MODALE',IP1,0,IRETOU)
  772. IF (IRETOU.EQ.0) GOTO 2300
  773. CALL ACCTAB(IP1,'MOT',0,0.D0,'MODES',.TRUE.,0,
  774. > 'TABLE',ID3,RR1,' ',.TRUE.,MTABLE)
  775. c fusion des 2 maillages
  776. CALL ACCTAB(MTABLE,'MOT',0,0.D0,'MAILLAGE',.TRUE.,0,
  777. > 'MAILLAGE',ID3,RR1,' ',.TRUE.,IPT2)
  778. CALL FUSE(IPT1,IPT2,IPT3,.FALSE.)
  779. CALL UNIQMA(IPT3,NBDIF)
  780. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MAILLAGE',.TRUE.,IP0,
  781. & 'MAILLAGE',0,0.0D0,' ',.TRUE.,IPT3)
  782. ENDIF
  783. GOTO 2100
  784. ENDIF
  785. c ---fin de boucle sur les tables IKO=1,2
  786.  
  787. 2300 CALL ECROBJ ('TABLE ',ipout)
  788. RETURN
  789.  
  790.  
  791. * =========
  792. * ERREUR 39
  793. * =========
  794. 999 CONTINUE
  795. * On ne veut pas d'objet de type %m1:8
  796. MOTERR(1:8)=CTYP
  797. CALL ERREUR(39)
  798. RETURN
  799.  
  800. END
  801.  
  802.  
  803.  
  804.  
  805.  
  806.  
  807.  
  808.  
  809.  
  810.  
  811.  

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