Télécharger prfuse.eso

Retour à la liste

Numérotation des lignes :

  1. C PRFUSE SOURCE CB215821 20/07/29 21:16:02 10668
  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*(LOCHAI) 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. CALL QUETYP(CTYP2 , ICODE , IRETOU )
  260. MOTERR(9:16)=CTYP2
  261. CALL MESLIR(-370)
  262. CALL LIROBJ(CTYP,IP2,ICODE,IRETOU)
  263. IF(IRETOU .EQ. 1) CALL ACTOBJ(CTYP,IP2,1)
  264. IF(IERR.NE.0) RETURN
  265.  
  266. GOTO ( 1,2,3,4,205,206,207,999,999,210,211,212,214,215,216,
  267. $ 217,218,219,220,221,222,223,224,226,227),II
  268.  
  269. *-- Création maillage
  270. 1 CONTINUE
  271. CALL CRELEM(IP1)
  272. 2 CONTINUE
  273. IF (CTYP.NE.'POINT '.AND.CTYP.NE.'MAILLAGE') GOTO 999
  274. IF(IRETOU.EQ.1.AND.CTYP.EQ.'POINT ') THEN
  275. * on a deux points
  276. CALL CRELEM(IP2)
  277. ENDIF
  278. IF(IRETOU.EQ.0) THEN
  279. * on a lu des objets de types différents mais compatibles
  280. CALL MESLIR(-220)
  281. IF(CTYP.EQ.'POINT ') CALL LIROBJ('MAILLAGE',IP2,1,IRETAU)
  282. IF(CTYP.EQ.'MAILLAGE') THEN
  283. CALL LIROBJ('POINT ',IP2,1,IRETAU)
  284. IF(IRETAU.EQ.1) CALL CRELEM(IP2)
  285. ENDIF
  286. IF(IERR.NE.0) RETURN
  287. ENDIF
  288. CTYP='MAILLAGE'
  289. CALL FUSE(IP1,IP2,IRETOU,LTELQ)
  290. GOTO 100
  291.  
  292. *-- Création CHPOINT
  293. 3 CONTINUE
  294. IF(IRETOU.EQ.1) THEN
  295. * La concaténation de deux champ-points donne un champ-point
  296. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  297. CALL FUCHPO(IP1,IP2,IRETOU)
  298. IF (IRETOU.NE.IP1.AND.IRETOU.NE.IP2)
  299. & CALL ACTOBJ('CHPOINT ',IRETOU,1)
  300. GOTO 100
  301. ELSE
  302. *PM autrement, on peut obtenir une liste de chpoints
  303. CALL CRLCHP(IP1)
  304. GOTO 226
  305. ENDIF
  306.  
  307. *-- Création RIGIDITE
  308. 4 CONTINUE
  309. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  310. CALL FUSRIG(IP1,IP2,IRETOU)
  311. GOTO 100
  312. *-- Création STRUCTURE
  313. 205 CONTINUE
  314. CALL FUSTRU(IP1,IP2,IRETOU)
  315. GOTO 100
  316. *-- Création SOLUTION
  317. 206 CONTINUE
  318. CALL FUSOLU(IP1,IP2,IRETOU)
  319. GOTO 100
  320. *-- Création ATTACHE
  321. 207 CONTINUE
  322. CALL FUSATT(IP1,IP2,IRETOU)
  323. GOTO 100
  324. *-- Création ELEMSTRU
  325. 210 CONTINUE
  326. CALL FUSELS(IP1,IP2,IRETOU)
  327. GOTO 100
  328. *-- Création BLOQSTRU
  329. 211 CONTINUE
  330. CALL FUSCLS(IP1,IP2,IRETOU)
  331. GOTO 100
  332. *-- Création BASE MODALE
  333. 212 CONTINUE
  334. CALL FUSBAS(IP1,IP2,IRETOU)
  335. GOTO 100
  336. *-- Opération LOGIQUE
  337. 213 CONTINUE
  338. IR3=IR1.AND.IR2
  339. CALL ECRLOG(IR3)
  340. RETURN
  341. *-- Création DEFORMEE
  342. 214 CONTINUE
  343. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  344. CALL FUSDEF(IP1,IP2,IRETOU)
  345. GOTO 100
  346. *-- Création VECTEUR
  347. 215 CONTINUE
  348. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  349. CALL FUSVEC (IP1,IP2,IRETOU)
  350. GOTO 100
  351. *-- Création CHARGEMENT
  352. 216 CONTINUE
  353. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  354. CALL FUSCHA(IP1,IP2,IRETOU)
  355. GOTO 100
  356.  
  357. *-- Création LISTREEL
  358. 217 CONTINUE
  359. IF(IP1 .NE. 0)THEN
  360. C On a lu un LISTREEL en 1er argument
  361. IF(IRETOU.EQ.0) THEN
  362. C On n'a pas lu un LISTREEL en 2eme argument
  363. CALL QUETYP(CTYP,1,IRETOU)
  364. IF(IERR.NE.0) RETURN
  365. IF((CTYP.NE.'ENTIER ').AND.(CTYP.NE.'FLOTTANT')) GOTO 999
  366. C On a lu des objets de types différents mais compatibles
  367. IF (CTYP.EQ.'ENTIER ') THEN
  368. CALL LIRENT(IVAL2,1,IRETOU)
  369. XVAL2=FLOAT(IVAL2)
  370. ELSE
  371. CALL LIRREE(XVAL2,1,IRETOU)
  372. ENDIF
  373. IF(IERR.NE.0) RETURN
  374.  
  375. MLREE2=IP1
  376. SEGACT,MLREE2
  377. JG1=MLREE2.PROG(/1)
  378. JG =JG1 + 1
  379. SEGINI,MLREE1
  380. MLREE1.PROG(JG)=XVAL2
  381. IF(JG1 .GT. 0)THEN
  382. C Recopie en FORTRAN
  383. CALL OPTABJ(1,1,3,1,
  384. & MLREE2.PROG(1),MLREE2.PROG(1),MLREE1.PROG(1),
  385. & JG1 ,JG1 ,JG1,
  386. & 1,0,0.D0,IRETOU)
  387. ENDIF
  388. ELSE
  389. C On a lu un LISTREEL en 2eme argument
  390. CALL FUSPRO(IP1,IP2,IRETOU)
  391. MLREE1=IRETOU
  392. ENDIF
  393. ELSE
  394. C On n'a pas lu un LISTREEL en 1er argument
  395. IF(IRETOU.EQ.0) THEN
  396. C On n'a pas lu un LISTREEL en 2eme argument
  397. CALL QUETYP(CTYP,1,IRETOU)
  398. IF(IERR.NE.0) RETURN
  399. IF((CTYP.NE.'ENTIER ').AND.(CTYP.NE.'FLOTTANT')) GOTO 999
  400. C On a lu des objets de types différents mais compatibles
  401. IF (CTYP.EQ.'ENTIER ') THEN
  402. CALL LIRENT(IVAL2,1,IRETOU)
  403. XVAL2=FLOAT(IVAL2)
  404. ELSE
  405. CALL LIRREE(XVAL2,1,IRETOU)
  406. ENDIF
  407. IF(IERR.NE.0) RETURN
  408. JG=2
  409. SEGINI,MLREE1
  410. MLREE1.PROG(1)=XVAL1
  411. MLREE1.PROG(2)=XVAL2
  412. ELSE
  413. C On a lu un LISTREEL en 2eme argument
  414. MLREE2=IP2
  415. SEGACT,MLREE2
  416. JG1=MLREE2.PROG(/1)
  417. JG =JG1 + 1
  418. SEGINI,MLREE1
  419. MLREE1.PROG(1)=XVAL1
  420. IF(JG1 .GT. 0) THEN
  421. C Recopie en FORTRAN
  422. CALL OPTABJ(1,1,3,1,
  423. & MLREE2.PROG(1),MLREE2.PROG(1),MLREE1.PROG(2),
  424. & JG1 ,JG1 ,JG1,
  425. & 1,0,0.D0,IRETOU)
  426. ENDIF
  427. ENDIF
  428. ENDIF
  429. CTYP='LISTREEL'
  430. SEGACT,MLREE1*NOMOD
  431. IRETOU=MLREE1
  432. GOTO 100
  433.  
  434. *-- Création LISTENTI
  435. 218 CONTINUE
  436. IF(IRETOU.EQ.0) THEN
  437. * on n'a pas lu un LISTENTI
  438. CALL QUETYP(CTYP,1,IRETOU)
  439. IF(IERR.NE.0) RETURN
  440. IF(CTYP.NE.'ENTIER ') GOTO 999
  441. CALL LIRENT(IP2,1,IRETOU)
  442. IF(IERR.NE.0) RETURN
  443. CALL CRELEC(IP2)
  444. ENDIF
  445. CTYP='LISTENTI'
  446. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  447. CALL FUSLEC(IP1,IP2,IRETOU)
  448. GOTO 100
  449.  
  450. *-- Création EVOLUTION
  451. 219 CONTINUE
  452. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  453. CALL FUEVOL(IP1,IP2,IRETOU)
  454. GOTO 100
  455. *-- Création MODELE
  456. 220 CONTINUE
  457. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  458. CALL FUSMOD(IP1,IP2,IRETOU)
  459. GOTO 100
  460. *-- Création MCHAML
  461. 221 CONTINUE
  462. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  463. CALL ETMCHL(IP1,IP2,IRETOU)
  464. GOTO 100
  465.  
  466. *-- Création LISTMOTS
  467. 222 CONTINUE
  468. IF (IP1 .GT. 0 .AND. IP2 .GT. 0) THEN
  469. C LISTMOTS 'ET' LISTMOTS
  470. CALL FUSMOT(IP1,IP2,IRETOU)
  471.  
  472. ELSEIF(IP1 .GT. 0 .AND. IP2 .EQ. 0) THEN
  473. C LISTMOTS 'ET' MOT
  474. CALL QUETYP(CTYP2,0,IRETOU)
  475. IF(CTYP2 .EQ. 'MOT') THEN
  476. CALL LIRCHA(LEMOT1,1,IRET1)
  477. IF (IERR.NE.0) RETURN
  478. MLMOT1=IP1
  479. SEGACT,MLMOT1
  480. JGN=MLMOT1.MOTS(/1)
  481. JGM=MLMOT1.MOTS(/2)+1
  482. SEGINI,MLMOT2
  483. IRETOU=MLMOT2
  484. DO III=1,JGM-1
  485. MLMOT2.MOTS(III)=MLMOT1.MOTS(III)
  486. ENDDO
  487. MLMOT2.MOTS(JGM)=LEMOT1
  488. SEGDES,MLMOT1,MLMOT2
  489. ELSE
  490. GOTO 999
  491. ENDIF
  492.  
  493. ELSEIF(IP1 .EQ. 0 .AND. IP2 .GT. 0) THEN
  494. C MOT 'ET' LISTMOTS
  495. IF(CTYP .EQ. 'MOT') THEN
  496. CTYP = CTYP2
  497. MLMOT1=IP2
  498. SEGACT,MLMOT1
  499. JGN=MLMOT1.MOTS(/1)
  500. JGM=MLMOT1.MOTS(/2)+1
  501. SEGINI,MLMOT2
  502. IRETOU=MLMOT2
  503. MLMOT2.MOTS(1)=LEMOT1(1:JGN)
  504. DO III=2,JGM
  505. MLMOT2.MOTS(III)=MLMOT1.MOTS(III-1)
  506. ENDDO
  507. SEGDES,MLMOT1,MLMOT2
  508. ELSE
  509. GOTO 999
  510. ENDIF
  511. ENDIF
  512. GOTO 100
  513. *-- Création NUAGE
  514. 223 CONTINUE
  515. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  516. CALL FUSNUA(IP1,IP2,IRETOU)
  517. GOTO 100
  518. *-- Création MATRIK
  519. 224 CONTINUE
  520. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  521. CALL FUSMTK(IP1,IP2,IRETOU)
  522. GOTO 100
  523. *-- Création LISTCHPO
  524. 226 CONTINUE
  525. IF (CTYP.NE.'CHPOINT '.AND.CTYP.NE.'LISTCHPO') GOTO 999
  526. IF(IRETOU.EQ.0) THEN
  527. * on a lu des objets de types différents mais compatibles
  528. * (le cas de 2 champ-points est traité ailleurs)
  529. CALL MESLIR(-221)
  530. IF(CTYP.EQ.'CHPOINT ') THEN
  531. CALL LIROBJ('LISTCHPO',IP2,1,IRETAU)
  532. CALL ACTOBJ('LISTCHPO',IP2,1)
  533. ELSE
  534. CALL LIROBJ('CHPOINT ',IP2,1,IRETAU)
  535. CALL ACTOBJ('CHPOINT ',IP2,1)
  536. CALL CRLCHP(IP2)
  537. ENDIF
  538. IF(IERR.NE.0) RETURN
  539. ENDIF
  540. CTYP='LISTCHPO'
  541. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  542. CALL FUSSUI(IP1,IP2,IRETOU)
  543. GOTO 100
  544. *-- Création ANNOTATI
  545. 227 CONTINUE
  546. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  547. MANNO1=IP1
  548. MANNO2=IP2
  549. SEGACT,MANNO1,MANNO2
  550. NBANN1=MANNO1.ICLAS(/1)
  551. NBANN2=MANNO2.ICLAS(/1)
  552. NBANNO=NBANN1+NBANN2
  553. SEGINI,MANNO3
  554. DO K1=1,NBANN1
  555. MANNO3.ICLAS(K1) = MANNO1.ICLAS(K1)
  556. MANNO3.ISEGT(K1) = MANNO1.ISEGT(K1)
  557. ENDDO
  558. DO K2=1,NBANN2
  559. MANNO3.ICLAS(NBANN1+K2) = MANNO2.ICLAS(K2)
  560. MANNO3.ISEGT(NBANN1+K2) = MANNO2.ISEGT(K2)
  561. ENDDO
  562. IRETOU=MANNO3
  563. GOTO 100
  564.  
  565. * Sortie sans problème, écriture résultat
  566. 100 CONTINUE
  567. CALL ACTOBJ(CTYP,IRETOU,1)
  568. CALL ECROBJ(CTYP,IRETOU)
  569. RETURN
  570.  
  571. * Fusion de chaines, limitation à 512 caractères
  572. 225 CONTINUE
  573. IRET=IRET1+IRET2
  574. IF(IRET.GT.512) THEN
  575. CALL ERREUR(1110)
  576. RETURN
  577. ENDIF
  578. LEMOT(1:IRET1) = LEMOT1(1:IRET1)
  579. LEMOT(IRET1+1:IRET) = LEMOT2(1:IRET2)
  580. CALL ECRCHA(LEMOT(1:IRET))
  581. RETURN
  582.  
  583.  
  584. * ================
  585. * Deuxième syntaxe
  586. * ================
  587. * Fusion de tous les indices d'une table
  588.  
  589. 1000 CONTINUE
  590. MTABLE=IP1
  591. IF (IRETOU.EQ.1) THEN
  592. * ET DE TABLES ESCLAVE
  593. * WRITE(IOIMP,*) ' TABLE ESCLAVE DANS ET'
  594. * IF (LODESL) THEN
  595. * WRITE(IOIMP,*) ' LODESL REMIS À FAUX DANS PRFUSE '
  596. * LODESL=.FALSE.
  597. * CALL ABORT
  598. * ENDIF
  599. CALL ACCTAB(MTABLE,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,0,
  600. > 'MOT',ID3,RR1,CTYP,IR1,ID2)
  601. IF (CTYP.NE.'ESCLAVE') THEN
  602. * Donnez une TABLE de sous-type %m1:8
  603. MOTERR(1:8)='ESCLAVE'
  604. CALL ERREUR(-173)
  605. * Le sous-type de la table est incorrect
  606. CALL ERREUR(648)
  607. RETURN
  608. ENDIF
  609. SEGACT MTABLE
  610. ML=MLOTAB
  611. * L'INDICE 1 EST LE SOUSTYPE, l'INDICE 2 EST LE CREATEUR
  612. IND=MTABII(3)
  613. CTYP=' '
  614. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  615. > CTYP,ID3,RR1,TYPRET,IR1,ID1)
  616. IRETOU=ID1
  617. IF (CTYP.EQ.'POINT') THEN
  618. NBNN=1
  619. NBSOUS=0
  620. NBREF=0
  621. NBELEM=ML-2
  622. SEGINI MELEME
  623. ITYPEL=1
  624. NUM(1,1)=ID1
  625. ICOLOR(1)=IDCOUL
  626. DO I=4,ML
  627. IND=MTABII(I)
  628. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  629. > CTYP,ID3,RR1,' ',IR1,ID2)
  630. IF (IERR.NE.0) RETURN
  631. NUM(1,I-2)=ID2
  632. ICOLOR(I-2)=IDCOUL
  633. ENDDO
  634. IRETOU=MELEME
  635. CTYP='MAILLAGE'
  636. ELSEIF (CTYP.EQ.'FLOTTANT') THEN
  637. JG=ML-2
  638. SEGINI,MLREE1
  639. MLREE1.PROG(1)=RR1
  640. DO I=4,ML
  641. IND=MTABII(I)
  642. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  643. > CTYP,ID3,RR1,' ',IR1,ID2)
  644. IF (IERR.NE.0) RETURN
  645. MLREE1.PROG(I-2)=RR1
  646. ENDDO
  647. IRETOU= MLREE1
  648. CTYP ='LISTREEL'
  649. ELSEIF (CTYP.EQ.'ENTIER') THEN
  650. JG=ML-2
  651. SEGINI,MLENT1
  652. MLENT1.LECT(1)=ID3
  653. DO I=4,ML
  654. IND=MTABII(I)
  655. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  656. > CTYP,ID3,RR1,' ',IR1,ID2)
  657. IF (IERR.NE.0) RETURN
  658. MLENT1.LECT(I-2)=ID3
  659. ENDDO
  660. IRETOU= MLENT1
  661. CTYP ='LISTENTI'
  662. ELSEIF (CTYP.EQ.'MAILLAGE') THEN
  663. DO I=4,ML
  664. IND=MTABII(I)
  665. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  666. > CTYP,ID3,RR1,' ',IR1,ID2)
  667. IF (IERR.NE.0) RETURN
  668. CALL FUSE(ID1,ID2,IRETOU,LTELQ)
  669. ID1=IRETOU
  670. ENDDO
  671. ELSEIF (CTYP.EQ.'MCHAML') THEN
  672. DO I=4,ML
  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 FUSCHL(ID1,ID2,IRETOU)
  678. ID1=IRETOU
  679. ENDDO
  680. ELSEIF (CTYP.EQ.'CHPOINT ') THEN
  681. DO I=4,ML
  682. IND=MTABII(I)
  683. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  684. > CTYP,ID3,RR1,' ',IR1,ID2)
  685. IF (IERR.NE.0) RETURN
  686. CALL FUCHPO(ID1,ID2,IRETOU)
  687. IF (IERR.NE.0) RETURN
  688. ID1=IRETOU
  689. ENDDO
  690. ELSEIF (CTYP.EQ.'RIGIDITE') THEN
  691. DO I=4,ML
  692. IND=MTABII(I)
  693. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  694. > CTYP,ID3,RR1,' ',IR1,ID2)
  695. IF (IERR.NE.0) RETURN
  696. CALL FUSRIG(ID1,ID2,IRETOU)
  697. IF (IERR.NE.0) RETURN
  698. ID1=IRETOU
  699. ENDDO
  700. ELSEIF (CTYP.EQ.'MATRIK ') THEN
  701. DO I=4,ML
  702. IND=MTABII(I)
  703. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  704. > CTYP,ID3,RR1,' ',IR1,ID2)
  705. IF (IERR.NE.0) RETURN
  706. CALL FUSMTK(ID1,ID2,IRETOU)
  707. IF (IERR.NE.0) RETURN
  708. ID1=IRETOU
  709. ENDDO
  710. ELSEIF (CTYP.EQ.'MMODEL') THEN
  711. DO I=4,ML
  712. IND=MTABII(I)
  713. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  714. > CTYP,ID3,RR1,' ',IR1,ID2)
  715. IF (IERR.NE.0) RETURN
  716. CALL FUSMOD(ID1,ID2,IRETOU)
  717. IF (IERR.NE.0) RETURN
  718. ID1=IRETOU
  719. ENDDO
  720. ELSEIF (CTYP.EQ.'LISTREEL') THEN
  721. DO I=4,ML
  722. IND=MTABII(I)
  723. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  724. > CTYP,ID3,RR1,' ',IR1,ID2)
  725. IF (IERR.NE.0) RETURN
  726. CALL FUSPRO(ID1,ID2,IRETOU)
  727. IF (IERR.NE.0) RETURN
  728. ID1=IRETOU
  729. ENDDO
  730. ELSEIF (CTYP.EQ.'LISTENTI') THEN
  731. DO I=4,ML
  732. IND=MTABII(I)
  733. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  734. > CTYP,ID3,RR1,' ',IR1,ID2)
  735. IF (IERR.NE.0) RETURN
  736. CALL FUSLEC(ID1,ID2,IRETOU)
  737. IF (IERR.NE.0) RETURN
  738. ID1=IRETOU
  739. ENDDO
  740. ELSE
  741. * On ne veut pas d'objet de type %m1:8
  742. MOTERR(1:8)=CTYP
  743. CALL ERREUR(39)
  744. RETURN
  745. ENDIF
  746. SEGDES,MTABLE
  747. GOTO 100
  748. ENDIF
  749.  
  750.  
  751. * =================
  752. * Troisième syntaxe
  753. * =================
  754. * FUSION TABLE DE MODES
  755.  
  756. 2000 CONTINUE
  757.  
  758. CALL CRTABL(IPTAB2)
  759. IPOUT = IPTAB2
  760. IL = 0
  761. IF (LEMOT.EQ.'LIAISONS_STATIQUES') THEN
  762. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,IP0,
  763. & 'MOT',0,0.0D0,'LIAISONS_STATIQUES',.TRUE.,IP1)
  764. ELSE
  765. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,IP0,
  766. & 'MOT',0,0.0D0,'BASE_MODALE',.TRUE.,IP1)
  767. CALL CRTABL(IPTAB3)
  768. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MODES',.TRUE.,IP0,
  769. & 'TABLE',0,0.0D0,' ',.TRUE.,IPTAB3)
  770. IPTAB2 = IPTAB3
  771. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,IP0,
  772. & 'MOT',0,0.0D0,'BASE_DE_MODES',.TRUE.,IP1)
  773. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MAILLAGE',.TRUE.,IP0,
  774. & 'MOT',0,0.0D0,'MAILLAGE',.TRUE.,IP1)
  775. cbp : plutot qu'ecrire le mot MAILLAGE(???), on fusionne les 2 maillages
  776. CALL ACCTAB(MTABLE,'MOT',0,0.D0,'MODES',.TRUE.,0,
  777. > 'TABLE',ID3,RR1,' ',.TRUE.,IP1)
  778. IF (IERR.NE.0) RETURN
  779. MTABLE = IP1
  780. CALL ACCTAB(IP1,'MOT',0,0.D0,'MAILLAGE',.TRUE.,0,
  781. > 'MAILLAGE',ID3,RR1,' ',.TRUE.,IPT1)
  782. IF (IERR.NE.0) RETURN
  783. ENDIF
  784.  
  785. c ---copie de la IKO ieme table (IKO=1,2)
  786. IKO = 0
  787. 2100 IKO = IKO + 1
  788. SEGACT MTABLE
  789.  
  790. c ---boucle sur les modes ou les solutions statiques
  791. IF (LEMOT.EQ.'LIAISONS_STATIQUES') THEN
  792. IMA = MLOTAB - 1
  793. ELSE
  794. IMA = MLOTAB - 2
  795. ENDIF
  796. IM = 0
  797. 2160 IM = IM + 1
  798. CTYP=' '
  799. CALL ACCTAB(MTABLE,'ENTIER',IM,0.D0,' ',.TRUE.,0,
  800. c > 'TABLE',ID3,RR1,' ',.TRUE.,ITMOD)
  801. > CTYP,ID3,RR1,' ',.TRUE.,ITMOD)
  802. IF(CTYP.NE.'TABLE') GOTO 2161
  803. IF (ITMOD.GT.0) THEN
  804. IL = IL + 1
  805. CALL ECCTAB(IPTAB2,'ENTIER',IL,0.0D0,' ',.TRUE.,IP0,
  806. & 'TABLE',0,0.0D0,' ',.TRUE.,ITMOD)
  807. ENDIF
  808. 2161 CONTINUE
  809. IF (IM.LT.IMA) GOTO 2160
  810. c ---fin de boucle sur les modes ou les solutions statiques
  811.  
  812. SEGDES MTABLE
  813. IF (IKO.EQ.1) THEN
  814. IF (LEMOT.EQ.'LIAISONS_STATIQUES') THEN
  815. CALL LIRTAB('LIAISONS_STATIQUES',IP1,0,IRETOU)
  816. IF (IRETOU.EQ.0) GOTO 2300
  817. MTABLE = IP1
  818. ELSE
  819. CALL LIRTAB('BASE_MODALE',IP1,0,IRETOU)
  820. IF (IRETOU.EQ.0) GOTO 2300
  821. CALL ACCTAB(IP1,'MOT',0,0.D0,'MODES',.TRUE.,0,
  822. > 'TABLE',ID3,RR1,' ',.TRUE.,MTABLE)
  823. c fusion des 2 maillages
  824. CALL ACCTAB(MTABLE,'MOT',0,0.D0,'MAILLAGE',.TRUE.,0,
  825. > 'MAILLAGE',ID3,RR1,' ',.TRUE.,IPT2)
  826. CALL FUSE(IPT1,IPT2,IPT3,.FALSE.)
  827. CALL UNIQMA(IPT3,NBDIF)
  828. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MAILLAGE',.TRUE.,IP0,
  829. & 'MAILLAGE',0,0.0D0,' ',.TRUE.,IPT3)
  830. ENDIF
  831. GOTO 2100
  832. ENDIF
  833. c ---fin de boucle sur les tables IKO=1,2
  834.  
  835. 2300 CALL ECROBJ('TABLE ',ipout)
  836. RETURN
  837.  
  838.  
  839. * =========
  840. * ERREUR 39
  841. * =========
  842. 999 CONTINUE
  843. * On ne veut pas d'objet de type %m1:8
  844. MOTERR(1:8)=CTYP
  845. CALL ERREUR(39)
  846. END
  847.  
  848.  
  849.  

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