Télécharger prfuse.eso

Retour à la liste

Numérotation des lignes :

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

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