Télécharger prfuse.eso

Retour à la liste

Numérotation des lignes :

prfuse
  1. C PRFUSE SOURCE SP204843 24/10/08 21:15:06 12026
  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. -INC SMLOBJE
  38.  
  39. EXTERNAL LONG
  40.  
  41. LOGICAL IR1,IR2,IR3,LTELQ
  42. CHARACTER*(8) CTYP,CTYP1,CTYP2,ICHAT,TYPRET,TYPRE1
  43. CHARACTER*(LOCHAI) LEMOT,LEMOT1,LEMOT2
  44. REAL*8 XVAL
  45. CHARACTER*4 LISTMO(1)
  46. DATA LISTMO / 'TELQ' /
  47.  
  48. IP0 = 0
  49. IP1 = 0
  50. IP2 = 0
  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. IF(CTYP.EQ.'LISTOBJE') THEN
  228. II = 26
  229. GOTO 24
  230. ENDIF
  231.  
  232. IF(CTYP.EQ.'TABLE') THEN
  233. MTABLE = IP1
  234. CALL ACCTAB(MTABLE,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,0,
  235. > 'MOT',ID3,RR1,LEMOT,IR1,ID2)
  236. IF (LEMOT.EQ.'LIAISONS_STATIQUES'.OR.
  237. > LEMOT.EQ.'BASE_MODALE') GOTO 2000
  238. GOTO 1000
  239. ENDIF
  240.  
  241. GOTO 999
  242.  
  243. ENDIF
  244.  
  245.  
  246. * ================
  247. * Première syntaxe
  248. * ================
  249.  
  250. * Lecture deuxième objet, lui aussi avec pointeur
  251. * -----------------------------------------------
  252. 24 CONTINUE
  253.  
  254. ICODE=1
  255. * pour les fusions mixtes, on est encore indécis sur le type du
  256. * deuxième objet.
  257. IF(CTYP.EQ.'POINT '.OR.CTYP.EQ.'MAILLAGE'.OR.
  258. & CTYP.EQ.'LISTENTI'.OR.CTYP.EQ.'LISTREEL'.OR.
  259. & CTYP.EQ.'LISTMOTS'.OR.
  260. & CTYP.EQ.'CHPOINT '.OR.CTYP.EQ.'LISTCHPO'.OR.
  261. & CTYP.EQ.'LISTOBJE') ICODE=0
  262.  
  263. * on lit a priori un objet de même type que le premier
  264. CALL QUETYP(CTYP2 , ICODE , IRETOU )
  265. * cas où on a un LISTOBJE uniquement, on fait la 2eme syntaxe
  266. IF (CTYP.EQ.'LISTOBJE'.AND.IRETOU.EQ.0) GOTO 1010
  267. IF (CTYP.EQ.'LISTOBJE'.OR.CTYP2.EQ.'LISTOBJE') THEN
  268. CALL LIROBJ(CTYP2,IP2,1,IRETOU)
  269. IF(IERR.NE.0) RETURN
  270. II = 26
  271. IF (CTYP.NE.'LISTOBJE') THEN
  272. IPX = IP2
  273. IP2 = IP1
  274. IP1 = IPX
  275. CTYP1 = CTYP2
  276. CTYP2 = CTYP
  277. CTYP = CTYP1
  278. ENDIF
  279. ELSE
  280. MOTERR(1:8)=CTYP
  281. CALL MESLIR(-221)
  282. CALL LIROBJ(CTYP,IP2,ICODE,IRETOU)
  283. IF(IRETOU .EQ. 1) CALL ACTOBJ(CTYP,IP2,1)
  284. IF(IERR.NE.0) RETURN
  285. ENDIF
  286.  
  287. GOTO ( 1,2,3,4,205,206,207,999,999,210,211,212,214,215,216,
  288. $ 217,218,219,220,221,222,223,224,226,227,228),II
  289.  
  290. *-- Création maillage
  291. 1 CONTINUE
  292. CALL CRELEM(IP1)
  293. 2 CONTINUE
  294. IF (CTYP.NE.'POINT '.AND.CTYP.NE.'MAILLAGE') GOTO 999
  295. IF(IRETOU.EQ.1.AND.CTYP.EQ.'POINT ') THEN
  296. * on a deux points
  297. CALL CRELEM(IP2)
  298. ENDIF
  299. IF(IRETOU.EQ.0) THEN
  300. * on a lu des objets de types différents mais compatibles
  301. CALL MESLIR(-220)
  302. IF(CTYP.EQ.'POINT ') CALL LIROBJ('MAILLAGE',IP2,1,IRETAU)
  303. IF(CTYP.EQ.'MAILLAGE') THEN
  304. CALL LIROBJ('POINT ',IP2,1,IRETAU)
  305. IF(IRETAU.EQ.1) CALL CRELEM(IP2)
  306. ENDIF
  307. IF(IERR.NE.0) RETURN
  308. ENDIF
  309. CTYP='MAILLAGE'
  310. CALL FUSE(IP1,IP2,IRETOU,LTELQ)
  311. GOTO 100
  312.  
  313. *-- Création CHPOINT
  314. 3 CONTINUE
  315. IF(IRETOU.EQ.1) THEN
  316. * La concaténation de deux champ-points donne un champ-point
  317. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  318. CALL FUCHPO(IP1,IP2,IRETOU)
  319. IF (IRETOU.EQ.0) RETURN
  320. IF (IRETOU.NE.IP1.AND.IRETOU.NE.IP2)
  321. & CALL ACTOBJ('CHPOINT ',IRETOU,1)
  322. GOTO 100
  323. ELSE
  324. *PM autrement, on peut obtenir une liste de chpoints
  325. CALL CRLCHP(IP1)
  326. GOTO 226
  327. ENDIF
  328.  
  329. *-- Création RIGIDITE
  330. 4 CONTINUE
  331. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  332. CALL FUSRIG(IP1,IP2,IRETOU)
  333. GOTO 100
  334. *-- Création STRUCTURE
  335. 205 CONTINUE
  336. CALL FUSTRU(IP1,IP2,IRETOU)
  337. GOTO 100
  338. *-- Création SOLUTION
  339. 206 CONTINUE
  340. CALL FUSOLU(IP1,IP2,IRETOU)
  341. GOTO 100
  342. *-- Création ATTACHE
  343. 207 CONTINUE
  344. CALL FUSATT(IP1,IP2,IRETOU)
  345. GOTO 100
  346. *-- Création ELEMSTRU
  347. 210 CONTINUE
  348. CALL FUSELS(IP1,IP2,IRETOU)
  349. GOTO 100
  350. *-- Création BLOQSTRU
  351. 211 CONTINUE
  352. CALL FUSCLS(IP1,IP2,IRETOU)
  353. GOTO 100
  354. *-- Création BASE MODALE
  355. 212 CONTINUE
  356. CALL FUSBAS(IP1,IP2,IRETOU)
  357. GOTO 100
  358. *-- Opération LOGIQUE
  359. 213 CONTINUE
  360. IR3=IR1.AND.IR2
  361. * lecture optionnelle d'autres logiques
  362. do i=1,1000
  363. call lirlog(ir2,0,iretou)
  364. if(iretou.eq.0) goto 2130
  365. ir3=ir3.and.ir2
  366. enddo
  367. 2130 continue
  368. CALL ECRLOG(IR3)
  369. RETURN
  370. *-- Création DEFORMEE
  371. 214 CONTINUE
  372. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  373. CALL FUSDEF(IP1,IP2,IRETOU)
  374. GOTO 100
  375. *-- Création VECTEUR
  376. 215 CONTINUE
  377. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  378. CALL FUSVEC (IP1,IP2,IRETOU)
  379. GOTO 100
  380. *-- Création CHARGEMENT
  381. 216 CONTINUE
  382. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  383. CALL FUSCHA(IP1,IP2,IRETOU)
  384. GOTO 100
  385.  
  386. *-- Création LISTREEL
  387. 217 CONTINUE
  388. IF(IP1 .NE. 0)THEN
  389. C On a lu un LISTREEL en 1er argument
  390. IF(IRETOU.EQ.0) THEN
  391. C On n'a pas lu un LISTREEL en 2eme argument
  392. CALL QUETYP(CTYP,1,IRETOU)
  393. IF(IERR.NE.0) RETURN
  394. IF((CTYP.NE.'ENTIER ').AND.(CTYP.NE.'FLOTTANT')) GOTO 999
  395. C On a lu des objets de types différents mais compatibles
  396. IF (CTYP.EQ.'ENTIER ') THEN
  397. CALL LIRENT(IVAL2,1,IRETOU)
  398. XVAL2=FLOAT(IVAL2)
  399. ELSE
  400. CALL LIRREE(XVAL2,1,IRETOU)
  401. ENDIF
  402. IF(IERR.NE.0) RETURN
  403.  
  404. MLREE2=IP1
  405. SEGACT,MLREE2
  406. JG1=MLREE2.PROG(/1)
  407. JG =JG1 + 1
  408. SEGINI,MLREE1
  409. MLREE1.PROG(JG)=XVAL2
  410. IF(JG1 .GT. 0)THEN
  411. C Recopie en FORTRAN
  412. CALL OPTABJ(1,1,3,1,
  413. & MLREE2.PROG(1),MLREE2.PROG(1),MLREE1.PROG(1),
  414. & JG1 ,JG1 ,JG1,
  415. & 1,0,0.D0,IRETOU)
  416. ENDIF
  417. ELSE
  418. C On a lu un LISTREEL en 2eme argument
  419. CALL FUSPRO(IP1,IP2,IRETOU)
  420. MLREE1=IRETOU
  421. ENDIF
  422. ELSE
  423. C On n'a pas lu un LISTREEL en 1er argument
  424. IF(IRETOU.EQ.0) THEN
  425. C On n'a pas lu un LISTREEL en 2eme argument
  426. CALL QUETYP(CTYP,1,IRETOU)
  427. IF(IERR.NE.0) RETURN
  428. IF((CTYP.NE.'ENTIER ').AND.(CTYP.NE.'FLOTTANT')) GOTO 999
  429. C On a lu des objets de types différents mais compatibles
  430. IF (CTYP.EQ.'ENTIER ') THEN
  431. CALL LIRENT(IVAL2,1,IRETOU)
  432. XVAL2=FLOAT(IVAL2)
  433. ELSE
  434. CALL LIRREE(XVAL2,1,IRETOU)
  435. ENDIF
  436. IF(IERR.NE.0) RETURN
  437. JG=2
  438. SEGINI,MLREE1
  439. MLREE1.PROG(1)=XVAL1
  440. MLREE1.PROG(2)=XVAL2
  441. ELSE
  442. C On a lu un LISTREEL en 2eme argument
  443. MLREE2=IP2
  444. SEGACT,MLREE2
  445. JG1=MLREE2.PROG(/1)
  446. JG =JG1 + 1
  447. SEGINI,MLREE1
  448. MLREE1.PROG(1)=XVAL1
  449. IF(JG1 .GT. 0) THEN
  450. C Recopie en FORTRAN
  451. CALL OPTABJ(1,1,3,1,
  452. & MLREE2.PROG(1),MLREE2.PROG(1),MLREE1.PROG(2),
  453. & JG1 ,JG1 ,JG1,
  454. & 1,0,0.D0,IRETOU)
  455. ENDIF
  456. ENDIF
  457. ENDIF
  458. CTYP='LISTREEL'
  459. SEGACT,MLREE1*NOMOD
  460. IRETOU=MLREE1
  461. GOTO 100
  462.  
  463. *-- Création LISTENTI
  464. 218 CONTINUE
  465. IF(IRETOU.EQ.0) THEN
  466. * on n'a pas lu un LISTENTI
  467. CALL QUETYP(CTYP,1,IRETOU)
  468. IF(IERR.NE.0) RETURN
  469. IF(CTYP.NE.'ENTIER ') GOTO 999
  470. CALL LIRENT(IP2,1,IRETOU)
  471. IF(IERR.NE.0) RETURN
  472. CALL CRELEC(IP2)
  473. ENDIF
  474. CTYP='LISTENTI'
  475. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  476. CALL FUSLEC(IP1,IP2,IRETOU)
  477. GOTO 100
  478.  
  479. *-- Création EVOLUTION
  480. 219 CONTINUE
  481. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  482. CALL FUEVOL(IP1,IP2,IRETOU)
  483. GOTO 100
  484. *-- Création MODELE
  485. 220 CONTINUE
  486. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  487. CALL FUSMOD(IP1,IP2,IRETOU)
  488. GOTO 100
  489. *-- Création MCHAML
  490. 221 CONTINUE
  491. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  492. CALL ETMCHL(IP1,IP2,IRETOU)
  493. GOTO 100
  494.  
  495. *-- Création LISTMOTS
  496. 222 CONTINUE
  497. IF (IP1 .GT. 0 .AND. IP2 .GT. 0) THEN
  498. C LISTMOTS 'ET' LISTMOTS
  499. CALL FUSMOT(IP1,IP2,IRETOU)
  500.  
  501. ELSEIF(IP1 .GT. 0 .AND. IP2 .EQ. 0) THEN
  502. C LISTMOTS 'ET' MOT
  503. CALL QUETYP(CTYP2,0,IRETOU)
  504. IF(CTYP2 .EQ. 'MOT') THEN
  505. CALL LIRCHA(LEMOT1,1,IRET1)
  506. IF (IERR.NE.0) RETURN
  507. MLMOT1=IP1
  508. SEGACT,MLMOT1
  509. JGN=MLMOT1.MOTS(/1)
  510. JGM=MLMOT1.MOTS(/2)+1
  511. SEGINI,MLMOT2
  512. IRETOU=MLMOT2
  513. DO III=1,JGM-1
  514. MLMOT2.MOTS(III)=MLMOT1.MOTS(III)
  515. ENDDO
  516. MLMOT2.MOTS(JGM)=LEMOT1
  517. SEGDES,MLMOT1,MLMOT2
  518. ELSE
  519. GOTO 999
  520. ENDIF
  521.  
  522. ELSEIF(IP1 .EQ. 0 .AND. IP2 .GT. 0) THEN
  523. C MOT 'ET' LISTMOTS
  524. IF(CTYP .EQ. 'MOT') THEN
  525. CTYP = CTYP2
  526. MLMOT1=IP2
  527. SEGACT,MLMOT1
  528. JGN=MLMOT1.MOTS(/1)
  529. JGM=MLMOT1.MOTS(/2)+1
  530. SEGINI,MLMOT2
  531. IRETOU=MLMOT2
  532. MLMOT2.MOTS(1)=LEMOT1(1:JGN)
  533. DO III=2,JGM
  534. MLMOT2.MOTS(III)=MLMOT1.MOTS(III-1)
  535. ENDDO
  536. SEGDES,MLMOT1,MLMOT2
  537. ELSE
  538. GOTO 999
  539. ENDIF
  540. ENDIF
  541. GOTO 100
  542. *-- Création NUAGE
  543. 223 CONTINUE
  544. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  545. CALL FUSNUA(IP1,IP2,IRETOU)
  546. GOTO 100
  547. *-- Création MATRIK
  548. 224 CONTINUE
  549. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  550. CALL FUSMTK(IP1,IP2,IRETOU)
  551. GOTO 100
  552. *-- Création LISTCHPO
  553. 226 CONTINUE
  554. IF (CTYP.NE.'CHPOINT '.AND.CTYP.NE.'LISTCHPO') GOTO 999
  555. IF(IRETOU.EQ.0) THEN
  556. * on a lu des objets de types différents mais compatibles
  557. * (le cas de 2 champ-points est traité ailleurs)
  558. CALL MESLIR(-221)
  559. IF(CTYP.EQ.'CHPOINT ') THEN
  560. CALL LIROBJ('LISTCHPO',IP2,1,IRETAU)
  561. CALL ACTOBJ('LISTCHPO',IP2,1)
  562. ELSE
  563. CALL LIROBJ('CHPOINT ',IP2,1,IRETAU)
  564. CALL ACTOBJ('CHPOINT ',IP2,1)
  565. CALL CRLCHP(IP2)
  566. ENDIF
  567. IF(IERR.NE.0) RETURN
  568. ENDIF
  569. CTYP='LISTCHPO'
  570. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  571. CALL FUSSUI(IP1,IP2,IRETOU)
  572. GOTO 100
  573. *-- Création ANNOTATI
  574. 227 CONTINUE
  575. IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
  576. MANNO1=IP1
  577. MANNO2=IP2
  578. SEGACT,MANNO1,MANNO2
  579. NBANN1=MANNO1.ICLAS(/1)
  580. NBANN2=MANNO2.ICLAS(/1)
  581. NBANNO=NBANN1+NBANN2
  582. SEGINI,MANNO3
  583. DO K1=1,NBANN1
  584. MANNO3.ICLAS(K1) = MANNO1.ICLAS(K1)
  585. MANNO3.ISEGT(K1) = MANNO1.ISEGT(K1)
  586. ENDDO
  587. DO K2=1,NBANN2
  588. MANNO3.ICLAS(NBANN1+K2) = MANNO2.ICLAS(K2)
  589. MANNO3.ISEGT(NBANN1+K2) = MANNO2.ISEGT(K2)
  590. ENDDO
  591. IRETOU=MANNO3
  592. GOTO 100
  593. *-- Creation LISTOBJE
  594. 228 CONTINUE
  595. C On a forcément un LISTOBJE en premier argument
  596. IF (CTYP.NE.CTYP2) THEN
  597. C LISTOBJE ET "un autre objet"
  598. MLOBJ1 = IP1
  599. SEGACT,MLOBJ1
  600. CTYP1 = MLOBJ1.TYPOBJ
  601. NBOB1 = MLOBJ1.LISOBJ(/1)
  602. IF (CTYP1.NE.CTYP2.AND.NBOB1.NE.0) THEN
  603. CTYP = CTYP2
  604. GOTO 999
  605. ENDIF
  606. NOBJ = 1
  607. SEGINI,MLOBJE
  608. TYPOBJ = CTYP2
  609. LISOBJ(1) = IP2
  610. IP2 = MLOBJE
  611. ENDIF
  612. CALL FUSLOB(IP1,IP2,IRETOU)
  613. IF (IERR.NE.0) RETURN
  614. GOTO 100
  615.  
  616. * Sortie sans problème, écriture résultat
  617. 100 CONTINUE
  618. CALL ACTOBJ(CTYP,IRETOU,1)
  619. CALL ECROBJ(CTYP,IRETOU)
  620. RETURN
  621.  
  622. * Fusion de chaines, limitation à 512 caractères
  623. 225 CONTINUE
  624. IRET=IRET1+IRET2
  625. IF(IRET.GT.512) THEN
  626. CALL ERREUR(1110)
  627. RETURN
  628. ENDIF
  629. LEMOT(1:IRET1) = LEMOT1(1:IRET1)
  630. LEMOT(IRET1+1:IRET) = LEMOT2(1:IRET2)
  631. CALL ECRCHA(LEMOT(1:IRET))
  632. RETURN
  633.  
  634.  
  635. * ================
  636. * Deuxième syntaxe
  637. * ================
  638. * Fusion de tous les indices d'une table
  639.  
  640. 1000 CONTINUE
  641. MTABLE=IP1
  642. IF (IRETOU.EQ.1) THEN
  643. * ET DE TABLES ESCLAVE
  644. * WRITE(IOIMP,*) ' TABLE ESCLAVE DANS ET'
  645. * IF (LODESL) THEN
  646. * WRITE(IOIMP,*) ' LODESL REMIS À FAUX DANS PRFUSE '
  647. * LODESL=.FALSE.
  648. * CALL ABORT
  649. * ENDIF
  650. CALL ACCTAB(MTABLE,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,0,
  651. > 'MOT',ID3,RR1,CTYP,IR1,ID2)
  652. IF (CTYP.NE.'ESCLAVE') THEN
  653. * Donnez une TABLE de sous-type %m1:8
  654. MOTERR(1:8)='ESCLAVE'
  655. CALL ERREUR(-173)
  656. * Le sous-type de la table est incorrect
  657. CALL ERREUR(648)
  658. RETURN
  659. ENDIF
  660. SEGACT MTABLE
  661. ML=MLOTAB
  662. * L'INDICE 1 EST LE SOUSTYPE, l'INDICE 2 EST LE CREATEUR
  663. IND=MTABII(3)
  664. CTYP=' '
  665. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  666. > CTYP,ID3,RR1,TYPRET,IR1,ID1)
  667. IRETOU=ID1
  668. IF (CTYP.EQ.'POINT') THEN
  669. NBNN=1
  670. NBSOUS=0
  671. NBREF=0
  672. NBELEM=ML-2
  673. SEGINI MELEME
  674. ITYPEL=1
  675. NUM(1,1)=ID1
  676. ICOLOR(1)=IDCOUL
  677. DO I=4,ML
  678. IND=MTABII(I)
  679. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  680. > CTYP,ID3,RR1,' ',IR1,ID2)
  681. IF (IERR.NE.0) RETURN
  682. NUM(1,I-2)=ID2
  683. ICOLOR(I-2)=IDCOUL
  684. ENDDO
  685. IRETOU=MELEME
  686. CTYP='MAILLAGE'
  687. ELSEIF (CTYP.EQ.'FLOTTANT') THEN
  688. JG=ML-2
  689. SEGINI,MLREE1
  690. MLREE1.PROG(1)=RR1
  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. MLREE1.PROG(I-2)=RR1
  697. ENDDO
  698. IRETOU= MLREE1
  699. CTYP ='LISTREEL'
  700. ELSEIF (CTYP.EQ.'ENTIER') THEN
  701. JG=ML-2
  702. SEGINI,MLENT1
  703. MLENT1.LECT(1)=ID3
  704. DO I=4,ML
  705. IND=MTABII(I)
  706. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  707. > CTYP,ID3,RR1,' ',IR1,ID2)
  708. IF (IERR.NE.0) RETURN
  709. MLENT1.LECT(I-2)=ID3
  710. ENDDO
  711. IRETOU= MLENT1
  712. CTYP ='LISTENTI'
  713. ELSEIF (CTYP.EQ.'MAILLAGE') THEN
  714. DO I=4,ML
  715. IND=MTABII(I)
  716. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  717. > CTYP,ID3,RR1,' ',IR1,ID2)
  718. IF (IERR.NE.0) RETURN
  719. CALL FUSE(ID1,ID2,IRETOU,LTELQ)
  720. IF (IERR.NE.0) RETURN
  721. ID1=IRETOU
  722. ENDDO
  723. ELSEIF (CTYP.EQ.'MCHAML') THEN
  724. DO I=4,ML
  725. IND=MTABII(I)
  726. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  727. > CTYP,ID3,RR1,' ',IR1,ID2)
  728. IF (IERR.NE.0) RETURN
  729. CALL FUSCHL(ID1,ID2,IRETOU)
  730. IF (IERR.NE.0) RETURN
  731. ID1=IRETOU
  732. ENDDO
  733. ELSEIF (CTYP.EQ.'CHPOINT ') THEN
  734. DO I=4,ML
  735. IND=MTABII(I)
  736. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  737. > CTYP,ID3,RR1,' ',IR1,ID2)
  738. IF (IERR.NE.0) RETURN
  739. CALL FUCHPO(ID1,ID2,IRETOU)
  740. IF (IERR.NE.0) RETURN
  741. ID1=IRETOU
  742. ENDDO
  743. ELSEIF (CTYP.EQ.'RIGIDITE') THEN
  744. DO I=4,ML
  745. IND=MTABII(I)
  746. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  747. > CTYP,ID3,RR1,' ',IR1,ID2)
  748. IF (IERR.NE.0) RETURN
  749. CALL FUSRIG(ID1,ID2,IRETOU)
  750. IF (IERR.NE.0) RETURN
  751. ID1=IRETOU
  752. ENDDO
  753. ELSEIF (CTYP.EQ.'MATRIK ') THEN
  754. DO I=4,ML
  755. IND=MTABII(I)
  756. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  757. > CTYP,ID3,RR1,' ',IR1,ID2)
  758. IF (IERR.NE.0) RETURN
  759. CALL FUSMTK(ID1,ID2,IRETOU)
  760. IF (IERR.NE.0) RETURN
  761. ID1=IRETOU
  762. ENDDO
  763. ELSEIF (CTYP.EQ.'MMODEL') THEN
  764. DO I=4,ML
  765. IND=MTABII(I)
  766. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  767. > CTYP,ID3,RR1,' ',IR1,ID2)
  768. IF (IERR.NE.0) RETURN
  769. CALL FUSMOD(ID1,ID2,IRETOU)
  770. IF (IERR.NE.0) RETURN
  771. ID1=IRETOU
  772. ENDDO
  773. ELSEIF (CTYP.EQ.'LISTREEL') THEN
  774. DO I=4,ML
  775. IND=MTABII(I)
  776. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  777. > CTYP,ID3,RR1,' ',IR1,ID2)
  778. IF (IERR.NE.0) RETURN
  779. CALL FUSPRO(ID1,ID2,IRETOU)
  780. IF (IERR.NE.0) RETURN
  781. ID1=IRETOU
  782. ENDDO
  783. ELSEIF (CTYP.EQ.'LISTENTI') THEN
  784. DO I=4,ML
  785. IND=MTABII(I)
  786. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  787. > CTYP,ID3,RR1,' ',IR1,ID2)
  788. IF (IERR.NE.0) RETURN
  789. CALL FUSLEC(ID1,ID2,IRETOU)
  790. IF (IERR.NE.0) RETURN
  791. ID1=IRETOU
  792. ENDDO
  793. ELSEIF (CTYP.EQ.'EVOLUTIO') THEN
  794. DO I=4,ML
  795. IND=MTABII(I)
  796. CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
  797. > CTYP,ID3,RR1,' ',IR1,ID2)
  798. IF (IERR.NE.0) RETURN
  799. CALL FUEVOL(ID1,ID2,IRETOU)
  800. IF (IERR.NE.0) RETURN
  801. ID1=IRETOU
  802. ENDDO
  803. ELSE
  804. * On ne veut pas d'objet de type %m1:8
  805. MOTERR(1:8)=CTYP
  806. CALL ERREUR(39)
  807. RETURN
  808. ENDIF
  809. SEGDES,MTABLE
  810. GOTO 100
  811. ENDIF
  812. * Fusion de tous les indices d'un LISTOBJE (copié sur les TABLES)
  813.  
  814. 1010 CONTINUE
  815. MLOBJE=IP1
  816. SEGACT MLOBJE
  817. CTYP=' '
  818. CTYP=TYPOBJ
  819. ML=LISOBJ(/1)
  820. ID1=LISOBJ(1)
  821. IF (CTYP.EQ.'POINT') THEN
  822. NBNN=1
  823. NBSOUS=0
  824. NBREF=0
  825. NBELEM=ML
  826. SEGINI MELEME
  827. ITYPEL=1
  828. DO I=1,ML
  829. NUM(1,I)=LISOBJ(I)
  830. ICOLOR(I)=IDCOUL
  831. ENDDO
  832. IRETOU=MELEME
  833. CTYP='MAILLAGE'
  834. ELSEIF (CTYP.EQ.'ENTIER') THEN
  835. JG=ML
  836. SEGINI,MLENT1
  837. DO I=1,ML
  838. MLENT1.LECT(I)=LISOBJ(I)
  839. ENDDO
  840. IRETOU= MLENT1
  841. CTYP ='LISTENTI'
  842. ELSEIF (CTYP.EQ.'MAILLAGE') THEN
  843. DO I=2,ML
  844. ID2=LISOBJ(I)
  845. CALL FUSE(ID1,ID2,IRETOU,LTELQ)
  846. IF (IERR.NE.0) RETURN
  847. ID1=IRETOU
  848. ENDDO
  849. ELSEIF (CTYP.EQ.'MCHAML') THEN
  850. DO I=2,ML
  851. ID2=LISOBJ(I)
  852. CALL FUSCHL(ID1,ID2,IRETOU)
  853. IF (IERR.NE.0) RETURN
  854. ID1=IRETOU
  855. ENDDO
  856. ELSEIF (CTYP.EQ.'CHPOINT ') THEN
  857. DO I=2,ML
  858. ID2=LISOBJ(I)
  859. CALL FUCHPO(ID1,ID2,IRETOU)
  860. IF (IERR.NE.0) RETURN
  861. ID1=IRETOU
  862. ENDDO
  863. ELSEIF (CTYP.EQ.'RIGIDITE') THEN
  864. DO I=2,ML
  865. ID2=LISOBJ(I)
  866. CALL FUSRIG(ID1,ID2,IRETOU)
  867. IF (IERR.NE.0) RETURN
  868. ID1=IRETOU
  869. ENDDO
  870. ELSEIF (CTYP.EQ.'MATRIK ') THEN
  871. DO I=2,ML
  872. ID2=LISOBJ(I)
  873. CALL FUSMTK(ID1,ID2,IRETOU)
  874. IF (IERR.NE.0) RETURN
  875. ID1=IRETOU
  876. ENDDO
  877. ELSEIF (CTYP.EQ.'MMODEL') THEN
  878. DO I=2,ML
  879. ID2=LISOBJ(I)
  880. CALL FUSMOD(ID1,ID2,IRETOU)
  881. IF (IERR.NE.0) RETURN
  882. ID1=IRETOU
  883. ENDDO
  884. ELSEIF (CTYP.EQ.'LISTREEL') THEN
  885. DO I=2,ML
  886. ID2=LISOBJ(I)
  887. CALL FUSPRO(ID1,ID2,IRETOU)
  888. IF (IERR.NE.0) RETURN
  889. ID1=IRETOU
  890. ENDDO
  891. ELSEIF (CTYP.EQ.'LISTENTI') THEN
  892. DO I=2,ML
  893. ID2=LISOBJ(I)
  894. CALL FUSLEC(ID1,ID2,IRETOU)
  895. IF (IERR.NE.0) RETURN
  896. ID1=IRETOU
  897. ENDDO
  898. ELSEIF (CTYP.EQ.'EVOLUTIO') THEN
  899. DO I=2,ML
  900. ID2=LISOBJ(I)
  901. CALL FUEVOL(ID1,ID2,IRETOU)
  902. IF (IERR.NE.0) RETURN
  903. ID1=IRETOU
  904. ENDDO
  905. ELSE
  906. * On ne veut pas d'objet de type %m1:8
  907. MOTERR(1:8)=CTYP
  908. CALL ERREUR(39)
  909. RETURN
  910. ENDIF
  911. GOTO 100
  912.  
  913. * =================
  914. * Troisième syntaxe
  915. * =================
  916. * FUSION TABLE DE MODES
  917.  
  918. 2000 CONTINUE
  919.  
  920. CALL CRTABL(IPTAB2)
  921. IPOUT = IPTAB2
  922. IL = 0
  923. IF (LEMOT.EQ.'LIAISONS_STATIQUES') THEN
  924. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,IP0,
  925. & 'MOT',0,0.0D0,'LIAISONS_STATIQUES',.TRUE.,IP1)
  926. ELSE
  927. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,IP0,
  928. & 'MOT',0,0.0D0,'BASE_MODALE',.TRUE.,IP1)
  929. CALL CRTABL(IPTAB3)
  930. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MODES',.TRUE.,IP0,
  931. & 'TABLE',0,0.0D0,' ',.TRUE.,IPTAB3)
  932. IPTAB2 = IPTAB3
  933. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,IP0,
  934. & 'MOT',0,0.0D0,'BASE_DE_MODES',.TRUE.,IP1)
  935. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MAILLAGE',.TRUE.,IP0,
  936. & 'MOT',0,0.0D0,'MAILLAGE',.TRUE.,IP1)
  937. cbp : plutot qu'ecrire le mot MAILLAGE(???), on fusionne les 2 maillages
  938. CALL ACCTAB(MTABLE,'MOT',0,0.D0,'MODES',.TRUE.,0,
  939. > 'TABLE',ID3,RR1,' ',.TRUE.,IP1)
  940. IF (IERR.NE.0) RETURN
  941. MTABLE = IP1
  942. CALL ACCTAB(IP1,'MOT',0,0.D0,'MAILLAGE',.TRUE.,0,
  943. > 'MAILLAGE',ID3,RR1,' ',.TRUE.,IPT1)
  944. IF (IERR.NE.0) RETURN
  945. ENDIF
  946.  
  947. c ---copie de la IKO ieme table (IKO=1,2)
  948. IKO = 0
  949. 2100 IKO = IKO + 1
  950. SEGACT MTABLE
  951.  
  952. c ---boucle sur les modes ou les solutions statiques
  953. IF (LEMOT.EQ.'LIAISONS_STATIQUES') THEN
  954. IMA = MLOTAB - 1
  955. ELSE
  956. IMA = MLOTAB - 2
  957. ENDIF
  958. IM = 0
  959. 2160 IM = IM + 1
  960. CTYP=' '
  961. CALL ACCTAB(MTABLE,'ENTIER',IM,0.D0,' ',.TRUE.,0,
  962. c > 'TABLE',ID3,RR1,' ',.TRUE.,ITMOD)
  963. > CTYP,ID3,RR1,' ',.TRUE.,ITMOD)
  964. IF(CTYP.NE.'TABLE') GOTO 2161
  965. IF (ITMOD.GT.0) THEN
  966. IL = IL + 1
  967. CALL ECCTAB(IPTAB2,'ENTIER',IL,0.0D0,' ',.TRUE.,IP0,
  968. & 'TABLE',0,0.0D0,' ',.TRUE.,ITMOD)
  969. ENDIF
  970. 2161 CONTINUE
  971. IF (IM.LT.IMA) GOTO 2160
  972. c ---fin de boucle sur les modes ou les solutions statiques
  973.  
  974. SEGDES MTABLE
  975. IF (IKO.EQ.1) THEN
  976. IF (LEMOT.EQ.'LIAISONS_STATIQUES') THEN
  977. CALL LIRTAB('LIAISONS_STATIQUES',IP1,0,IRETOU)
  978. IF (IRETOU.EQ.0) GOTO 2300
  979. MTABLE = IP1
  980. ELSE
  981. CALL LIRTAB('BASE_MODALE',IP1,0,IRETOU)
  982. IF (IRETOU.EQ.0) GOTO 2300
  983. CALL ACCTAB(IP1,'MOT',0,0.D0,'MODES',.TRUE.,0,
  984. > 'TABLE',ID3,RR1,' ',.TRUE.,MTABLE)
  985. c fusion des 2 maillages
  986. CALL ACCTAB(MTABLE,'MOT',0,0.D0,'MAILLAGE',.TRUE.,0,
  987. > 'MAILLAGE',ID3,RR1,' ',.TRUE.,IPT2)
  988. CALL FUSE(IPT1,IPT2,IPT3,.FALSE.)
  989. * A qoi sert cet appel a uniq?
  990. ** iordre=0
  991. ** CALL UNIQMA(IPT3,NBDIF,iordre)
  992. CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MAILLAGE',.TRUE.,IP0,
  993. & 'MAILLAGE',0,0.0D0,' ',.TRUE.,IPT3)
  994. ENDIF
  995. GOTO 2100
  996. ENDIF
  997. c ---fin de boucle sur les tables IKO=1,2
  998.  
  999. 2300 CALL ECROBJ('TABLE ',ipout)
  1000. RETURN
  1001.  
  1002.  
  1003. * =========
  1004. * ERREUR 39
  1005. * =========
  1006. 999 CONTINUE
  1007. * On ne veut pas d'objet de type %m1:8
  1008. MOTERR(1:8)=CTYP
  1009. CALL ERREUR(39)
  1010. END
  1011.  
  1012.  
  1013.  
  1014.  
  1015.  

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