Télécharger prchan.eso

Retour à la liste

Numérotation des lignes :

  1. C PRCHAN SOURCE FANDEUR 17/11/14 21:15:13 9613
  2.  
  3. SUBROUTINE PRCHAN
  4.  
  5. C--------------------------------------------------------------------
  6. C Ce sous programme permet :
  7. C
  8. C - De changer les elements d'un maillage
  9. C
  10. C - De convertir un MCHAML en CHPOINT (mot cle CHPO)
  11. C
  12. C - De convertir un CHPOINT en MCHAML (mot cle CHAM)
  13. C
  14. C - De changer le support d'un MCHAML
  15. C (mots cles NOEUDS, GRAVITE, RIGIDITE, MASSE et STRESSES)
  16. C
  17. C - De changer l'attribut d'un champ de points
  18. C
  19. C - De changer le nom du constituant d'un champ par element ou d un modele
  20. C
  21. C - De changer une rigidite cree par RELA en rigidite de dependence
  22. C
  23. C - Changer la casse d'un mot
  24. C--------------------------------------------------------------------
  25.  
  26. IMPLICIT INTEGER(I-N)
  27. IMPLICIT REAL*8(A-H,O-Z)
  28.  
  29. -INC CCOPTIO
  30. -INC CCHAMP
  31. -INC CCGEOME
  32.  
  33. -INC SMELEME
  34. -INC SMLENTI
  35. -INC SMCHPOI
  36. -INC SMCHAML
  37. -INC SMRIGID
  38. -INC SMMODEL
  39. -INC SMLMOTS
  40. -INC SMCOORD
  41.  
  42. PARAMETER (NTYP=27 , LATRI = 4, NLIG = 9 )
  43. CHARACTER*8 LISTYP(NTYP)
  44. CHARACTER*4 LATRIB(LATRI)
  45. CHARACTER*4 LISMAT(3), LISCOM(2),LISMUL(2)
  46. CHARACTER*4 MOTLIG(NLIG), MOMOYE(2)
  47. CHARACTER*72 CHAR,CHAR1
  48. CHARACTER*8 CHAR8,CNOM1,CNOM2
  49. PARAMETER (LMOTL=512)
  50. CHARACTER*(LMOTL) MENT,MSOR
  51.  
  52. DATA LISTYP / 'NOEUD ', 'GRAVITE ', 'RIGIDITE', 'MASSE ',
  53. & 'STRESSES', 'THERMIQU', 'FACE ', 'P1CENTRE',
  54. & 'MSOMMET ', 'CHPO ', 'CHAM ', '--------',
  55. & '--------', 'TYPE ', 'ATTRIBUT', 'CONS ',
  56. & 'DEPE ', 'COND ', 'COMP ', 'INCO ',
  57. & 'TABL ', 'MINU ', 'MAJU ', 'TITR ',
  58. & 'LEGE ', 'NOMABS ', 'NOMORD '/
  59.  
  60. DATA LATRIB / 'NATU', 'INDE', 'DIFF', 'DISC' /
  61.  
  62. DATA LISMAT / 'SYME', 'ANTI', 'QUEL' /
  63. DATA LISCOM / 'COMP', 'REEL' /
  64. DATA LISMUL / 'MULT','DUPL' /
  65.  
  66. DATA MOMOYE / 'SOMM', 'MOYE'/
  67. DATA MOTLIG / 'LIGN', 'LINE', 'QUAD', 'QUAF', 'MACR', 'CUBI',
  68. & 'DECL', 'LINB', 'SURF' /
  69.  
  70. ILIG=0
  71. CNOM1 = ' '
  72. CNOM2 = ' '
  73.  
  74. C --- Lecture des mots-clés de LISTYP --> IPLAC
  75. CALL LIRMOT(LISTYP,NTYP,IPLAC,0)
  76. IF (IERR.NE.0) RETURN
  77. IF (IPLAC.NE.0) GOTO 1
  78. C
  79. C --- Lecture des mots-clés de MOTLIG --> ILIG
  80. CALL LIRMOT(MOTLIG,NLIG,ILIG,0)
  81. IF (ILIG.EQ.1) THEN
  82. CALL CHANLG
  83. RETURN
  84. ELSEIF(ILIG.EQ.2) THEN
  85. CALL CHANLI
  86. RETURN
  87. ELSEIF(ILIG.EQ.3) THEN
  88. CALL CHANQU
  89. RETURN
  90. ELSEIF(ILIG.EQ.4) THEN
  91. CALL LIROBJ('MAILLAGE',MELEME,1,IRET)
  92. IF(IRET.EQ.0)RETURN
  93. CALL KQCEST(MELEME,IKR)
  94. CALL ECROBJ('MAILLAGE',MELEME)
  95. IF(IKR.EQ.2)THEN
  96. CALL CHANQU
  97. ENDIF
  98. CALL C20227
  99. RETURN
  100. ELSEIF(ILIG.EQ.5) THEN
  101. CALL CMACRO
  102. RETURN
  103. ELSEIF(ILIG.EQ.6) THEN
  104. CALL CCUBIC
  105. RETURN
  106. ELSEIF(ILIG.EQ.7) THEN
  107. CALL CQ2L
  108. RETURN
  109. ELSEIF(ILIG.EQ.8) THEN
  110. CALL CLINB
  111. RETURN
  112. ELSEIF(ILIG.EQ.9) THEN
  113. CALL ENVVO2(1)
  114. RETURN
  115. ENDIF
  116. C
  117. C --- Lecture parmi la liste des NOMS --> ITY
  118. CALL LIRMOT(NOMS,NOMBR,ITY,0)
  119. IF (ITY.EQ.0) ITY=ILCOUR
  120. CALL LIROBJ('MAILLAGE',MELEME,0,IRETOU)
  121. IF (IRETOU.EQ.0) GOTO 99
  122.  
  123. CALL QUENOM(CNOM1)
  124. C CB On ajoute la lecture d'un LISTENTIER optionnel pour indiquer
  125. C quels N-uplet de noeuds du MELEME vont constituer la connectivité
  126. C du MAILLAGE final
  127. CALL LIROBJ('LISTENTI',MLENTI,0,IRETOU)
  128. IF (IRETOU.NE.0) THEN
  129. CALL QUENOM(CNOM2)
  130. SEGACT,MELEME
  131. ITYP1 = MELEME.ITYPEL
  132. IF (ITYP1 .NE. 1) THEN
  133. CALL ERREUR(16)
  134. SEGDES,MELEME
  135. RETURN
  136. ENDIF
  137. NBEL1 = MELEME.NUM(/2)
  138. SEGACT,MLENTI
  139. JG = LECT(/1)
  140. C Cas des ELEMENTS POLY et MULT
  141. IF (NOMS(ITY).EQ.'POLY' .OR. NOMS(ITY).EQ.'MULT') THEN
  142. NBNN = JG
  143. NBELEM = 1
  144. C Cas des ELEMENTS classiques
  145. ELSE
  146. NBNN = NBNNE(ITY)
  147. NBELEM = JG/NBNN
  148. IF (MOD(JG,NBNN) .NE. 0) THEN
  149. MOTERR(1:8) =CNOM2
  150. MOTERR(9:12)=NOMS(ITY)
  151. CALL ERREUR(1057)
  152. SEGDES,MLENTI,MELEME
  153. RETURN
  154. ENDIF
  155. ENDIF
  156.  
  157. NBSOUS=0
  158. NBREF =0
  159. SEGINI,IPT1
  160. IPT1.ITYPEL=ITY
  161. DO 259 IEL=1,NBELEM
  162. J=(IEL-1) * NBNN
  163. IPT1.ICOLOR(IEL)=IDCOUL
  164. DO 259 I=1,NBNN
  165. IELEM = MLENTI.LECT(J+I)
  166. IF((IELEM .GT. NBEL1) .OR. (IELEM .LE. 0)) THEN
  167. INTERR(1) =IELEM
  168. MOTERR(1:8)=CNOM1
  169. C PRINT *,'PRCHAN',IELEM,J,I,J+I
  170. CALL ERREUR(1058)
  171. SEGDES,MELEME,MLENTI
  172. SEGSUP,IPT1
  173. RETURN
  174. ENDIF
  175. IPT1.NUM(I,IEL)=MELEME.NUM(1,IELEM)
  176. 259 CONTINUE
  177. SEGDES,MELEME,MLENTI
  178. MELEME = IPT1
  179. ELSE
  180. CALL CHANGE(MELEME,ITY)
  181. IF (IERR.NE.0) RETURN
  182. ENDIF
  183. SEGDES,MELEME
  184. CALL ECROBJ('MAILLAGE',MELEME)
  185. RETURN
  186.  
  187. C PAS D OPERANDE CORRECTE TROUVE --> ERREUR
  188. 99 CONTINUE
  189. CALL QUETYP(MOTERR(1:8),0,IRETOU)
  190. IF (IRETOU.NE.0) THEN
  191. CALL ERREUR (39)
  192. ELSE
  193. CALL ERREUR(533)
  194. ENDIF
  195. RETURN
  196. C
  197. C OPERANDE CORRECTE TROUVE dans LISTYP : on aiguille
  198. C
  199. 1 CONTINUE
  200. GOTO ( 300, 300, 300, 300, 300, 300, 300, 300, 300, 100,
  201. & 800, 400, 600,1200,1300,1400,1500,1500,1600,1700,
  202. & 2100,2200,2200,3000,3000,3000,3000),IPLAC
  203. C
  204. C CHANGEMENT D'UN MCHAML EN CHPOINT
  205. C
  206. 100 CALL LIRMOT(MOMOYE,2,IMOY,0)
  207. IF(IMOY.EQ.0) IMOY=2
  208. IMOY=IMOY-1
  209.  
  210. C Tente la lecture optionnelle d'un CHPOINT
  211. CALL LIROBJ('CHPOINT ',IPOI2,0,IRETO3)
  212. IF(IERR.NE.0) RETURN
  213.  
  214. IF(IRETO3.NE.0) THEN
  215. C Tente la lecture optionnelle d'un MMODEL
  216. CALL LIROBJ('MMODEL',IPOI1,0,IRETO1)
  217. IF(IERR.NE.0) RETURN
  218.  
  219. C L'OBJET fourni etait deja un CHPOINT on crée un CHPOINT dupliqué
  220. MCHPOI=IPOI2
  221. SEGINI,MCHPO1=MCHPOI
  222. SEGDES,MCHPO1
  223. CALL ECROBJ('CHPOINT ',MCHPO1)
  224. IF(IERR.NE.0) RETURN
  225. RETURN
  226. ENDIF
  227.  
  228. C Tente la lecture obligatoire d'un MMODEL
  229. CALL LIROBJ('MMODEL',IPOI1,1,IRETO1)
  230. IF(IERR.NE.0) RETURN
  231.  
  232. C Tente la lecture obligatoire d'un MCHAML
  233. CALL LIROBJ('MCHAML ',IPOI2,1,IRETO2)
  234. IF(IERR.NE.0) RETURN
  235. IF (IRETO2 .EQ. 1) THEN
  236. CALL REDUAF(IPOI2,IPOI1,IPOI3,0,IRET,KERR)
  237. IF (IRET .EQ. 0) THEN
  238. CALL ERREUR (KERR)
  239. IF(IERR .NE. 0) RETURN
  240. ELSE
  241. IPOI2 = IPOI3
  242. ENDIF
  243. ENDIF
  244.  
  245. CALL CHASUP(IPOI1,IPOI2,IPOI3,IRT2,1)
  246. IF(IRT2.NE.0) THEN
  247. CALL ERREUR(IRT2)
  248. RETURN
  249. ENDIF
  250. CALL CHAMPO(IPOI3,IMOY,IPOI4,IRET)
  251. C A PRIORI LE CHPO EST DE NATURE DIFFUSE
  252. MCHPOI = IPOI4
  253. SEGACT MCHPOI*MOD
  254. JATTRI(1) = 1
  255. SEGDES MCHPOI
  256. CALL ECROBJ('CHPOINT ',IPOI4)
  257. RETURN
  258.  
  259. 400 CONTINUE
  260. 600 CONTINUE
  261. RETURN
  262. C
  263. C CHANGEMENT D'UN CHPOINT EN MCHAML A PARTIR D'UN MODELE
  264. C
  265. C Lecture éventuelle d'un lieu support
  266. 800 CALL LIRMOT(LISTYP,9,ISUP,0)
  267. IF (IERR.NE.0) RETURN
  268. IPLAC = ISUP
  269. C Par defaut, le support est aux noeuds
  270. IF (IPLAC.EQ.0) IPLAC = 1
  271.  
  272. C Tente la lecture optionnelle d'un MCHAML
  273. CALL LIROBJ('MCHAML ',IPOI2,0,IRETOU)
  274. IF (IERR.NE.0) RETURN
  275. IF (IRETOU.NE.0) THEN
  276. CALL REFUS
  277. GOTO 300
  278. ENDIF
  279.  
  280. CALL LIROBJ('MMODEL ',IPOI1,0,IRETOU)
  281. IF (IERR.NE.0) RETURN
  282. IF (IRETOU.EQ.0) GOTO 900
  283.  
  284. CALL LIROBJ('CHPOINT ',IPOI2,1,IRETOU)
  285. IF(IERR.NE.0) RETURN
  286.  
  287. LONS=0
  288. MMODEL=IPOI1
  289. SEGACT MMODEL
  290. N1=KMODEL(/1)
  291. DO 41 L=1,N1
  292. IMODEL=KMODEL(L)
  293. SEGACT IMODEL
  294. IF (FORMOD(1).EQ.'NAVIER_STOKES') LONS=LONS+1
  295. SEGDES IMODEL
  296. 41 CONTINUE
  297. SEGDES MMODEL
  298.  
  299. IF(LONS.EQ.0) THEN
  300. C
  301. C Tente la lecture optionnelle du Sous_Type
  302. CALL LIRCHA(CHAR,0,IRETOU)
  303. IF (IERR.NE.0) RETURN
  304. IF (IRETOU.EQ.0) THEN
  305. CHAR=' '
  306. IRETOU=1
  307. ENDIF
  308.  
  309. CALL CHAME1(0,IPOI1,IPOI2,CHAR(1:IRETOU),IPOI3,IPLAC)
  310. IF (IERR.NE.0) RETURN
  311.  
  312. ELSEIF(LONS.EQ.N1) THEN
  313. C Traitement specifique dans le cas d'un objet modele de
  314. C type Navier-Stokes
  315. CALL KCHAM1(IPOI1,IPOI2,IPOI3)
  316. IF (IERR.NE.0) RETURN
  317. IF (ISUP.NE.0) THEN
  318. CALL CHASPG(IPOI1,IPOI3,IPOI4,IRET,ISUP)
  319. IF (IRET.NE.0) CALL ERREUR(IRET)
  320. IF (IERR.NE.0) RETURN
  321. IPOI3=IPOI4
  322. ENDIF
  323. ENDIF
  324. CALL ECROBJ('MCHAML ',IPOI3)
  325. RETURN
  326. C
  327. C CHANGEMENT DE CHPOINT EN MCHAML A PARTIR D'UN MAILLAGE
  328. C
  329. C Tente la lecture obligatoire d'un MAILLAGE
  330. 900 CALL LIROBJ('MAILLAGE',IPOI1,1,IRETO1)
  331. IF(IERR.NE.0) RETURN
  332.  
  333. C Tente la lecture obligatoire d'un CHPOINT
  334. CALL LIROBJ('CHPOINT ',IPOI2,1,IRETO2)
  335. IF(IERR.NE.0) RETURN
  336.  
  337. C Tente la lecture optionnelle du Sous_Type
  338. CALL LIRCHA(CHAR,0,IRETOU)
  339. IF(IERR.NE.0) RETURN
  340. C
  341. IF (IRETOU.EQ.0) THEN
  342. CHAR='SCALAIRE'
  343. IRETOU=8
  344. ENDIF
  345. C
  346. CALL CHAME1(IPOI1,0,IPOI2,CHAR(1:IRETOU),IPOI3,1)
  347. IF(IERR.NE.0) RETURN
  348. CALL ECROBJ('MCHAML ',IPOI3)
  349. RETURN
  350. C
  351. C CHANGEMENT DE SUPPORT D'UN MCHAML
  352. C
  353. 300 CALL LIROBJ('MCHAML',IPOI2,1,IRETOU)
  354. IF (IERR.NE.0) RETURN
  355.  
  356. CALL LIROBJ('MMODEL',IPOI1,1,IRETOU)
  357. IF(IERR.NE.0) RETURN
  358.  
  359. LONS=0
  360. MMODEL=IPOI1
  361. SEGACT MMODEL
  362. N1=KMODEL(/1)
  363. DO 42 L=1,N1
  364. IMODEL=KMODEL(L)
  365. SEGACT IMODEL
  366. IF(FORMOD(1).EQ.'NAVIER_STOKES') LONS=LONS+1
  367. SEGDES IMODEL
  368. 42 CONTINUE
  369. SEGDES MMODEL
  370.  
  371. IF(LONS.EQ.0) THEN
  372. C cas normal
  373. C On procède au REDUAF
  374. CALL REDUAF(IPOI2,IPOI1,IPOI3,0,IRET,KERR)
  375. IF (IRET .EQ. 0) THEN
  376. CALL ERREUR (KERR)
  377. IF (IERR .NE. 0) RETURN
  378. ENDIF
  379. IPOI2 = IPOI3
  380.  
  381. CALL CHASUP(IPOI1,IPOI2,IPOI3,IRT2,IPLAC)
  382. IF(IRT2.NE.0) THEN
  383. CALL ERREUR(IRT2)
  384. RETURN
  385. ENDIF
  386. ELSEIF(LONS.EQ.N1) THEN
  387. C Traitement specifique dans le cas d'un objet modele de
  388. C type Navier-Stokes
  389. CALL CHASPG(IPOI1,IPOI2,IPOI3,IRT2,IPLAC)
  390. IF (IRT2.NE.0) CALL ERREUR(IRT2)
  391. IF (IERR.NE.0) RETURN
  392. ENDIF
  393.  
  394. C Tente la lecture optionnelle du Sous_Type
  395. CALL LIRCHA(CHAR,0,IRETOU)
  396. IF(IERR.NE.0) RETURN
  397. IF (IRETOU .NE.0) THEN
  398. IPOI1=IPOI3
  399. GOTO 1201
  400. ENDIF
  401. C
  402. CALL ECROBJ('MCHAML',IPOI3)
  403. RETURN
  404. C
  405. C CHANGEMENT DE TITRE (mot clé 'TYPE') D'UN MCHAML
  406. C
  407. 1200 CALL LIROBJ('MCHAML',IPOI1,0,IRETOU)
  408. c mot clé 'TYPE' aussi utilisé pour RIGIDITE
  409. IF(IRETOU.EQ.0) GOTO 1250
  410. CALL LIRCHA(CHAR,1,IRETOU)
  411. IF(IERR.NE.0) RETURN
  412.  
  413. 1201 CALL CHATIT(IPOI1,CHAR(1:IRETOU),IPOI2)
  414. CALL ECROBJ('MCHAML',IPOI2)
  415. RETURN
  416. C
  417. C CHANGEMENT DU TYPE D'UNE RIGIDITE
  418. C
  419. 1250 CALL LIROBJ('RIGIDITE',IRIG,1,IRETOU)
  420. IF (IERR.NE.0) RETURN
  421. RI1 = IRIG
  422. SEGINI,MRIGID=RI1
  423. CALL LIRCHA(CHAR8,1,IRETOU)
  424. IF(IERR.NE.0) RETURN
  425. MTYMAT = CHAR8
  426. SEGDES,MRIGID
  427. CALL ECROBJ('RIGIDITE',MRIGID)
  428. RETURN
  429. C
  430. C CHANGEMENT DE L'ATTRIBUT D'UN CHAMP DE POINTS
  431. C
  432. 1300 CONTINUE
  433. C
  434. CALL LIRMOT(LATRIB,LATRI,IPLAC,1)
  435. IF (IERR.NE.0) RETURN
  436. CALL LIROBJ('CHPOINT ',IPOI1,1,IRETOU)
  437. IF (IERR.NE.0) RETURN
  438. MCHPOI = IPOI1
  439. C CHANGEMENT DE NATURE
  440. IF ( IPLAC .EQ. 1 ) THEN
  441. CALL LIRMOT(LATRIB,LATRI,IPLAC,1)
  442. IPLAC = IPLAC - 2
  443. SEGINI, MCHPO1=MCHPOI
  444. DO iou=1,mchpo1.ipchp(/1)
  445. msoupo=mchpo1.ipchp(iou)
  446. segini,msoup1=msoupo
  447. mchpo1.ipchp(iou)=msoup1
  448. segdes msoup1
  449. ENDDO
  450. IPOI2 = MCHPO1
  451. MCHPO1.JATTRI(1) = IPLAC
  452. SEGDES, MCHPOI,MCHPO1
  453. CALL ECROBJ('CHPOINT ',IPOI2)
  454. ELSE
  455. MOTERR(1:4)='NATU'
  456. CALL ERREUR(396)
  457. RETURN
  458. ENDIF
  459. RETURN
  460. C
  461. C CHANGEMENT DE CONSTITUANT D'UN MCHAML ou d'un MMODEL
  462. C
  463. 1400 CALL LIROBJ('MCHAML',IPOI1,0,IRETOU)
  464. IF (IERR.NE.0) RETURN
  465. IF (iretou.ne.0) THEN
  466. MCHELM = IPOI1
  467. SEGINI , MCHEL1 = MCHELM
  468. CALL LIRCHA(CHAR,1,LCHAR)
  469. IF (IERR.NE.0) RETURN
  470. N1 = MCHEL1.CONCHE(/2)
  471. CHAR1 = MCHEL1.CONCHE(1)
  472. DO 1410 I=1,N1
  473. IF ( MCHEL1.CONCHE(I) .NE. CHAR1) THEN
  474. CALL ERREUR(716)
  475. SEGSUP MCHEL1
  476. RETURN
  477. ENDIF
  478. 1410 CONTINUE
  479.  
  480. DO 1420 I=1,N1
  481. MCHEL1.CONCHE(I) = CHAR
  482. 1420 CONTINUE
  483. SEGDES MCHEL1
  484. IPOI1 = MCHEL1
  485. CALL ECROBJ('MCHAML',IPOI1)
  486. RETURN
  487.  
  488. ELSE
  489. CALL LIROBJ('MMODEL ',IPOI1,0,IRETOU)
  490. IF (ierr.ne.0) RETURN
  491. IF (iretou.eq.0) THEN
  492. moterr(1:8) = 'MCHAML '
  493. moterr(9:16)= 'MMODEL '
  494. CALL erreur(471)
  495. RETURN
  496. ENDIF
  497. mmode1 = ipoi1
  498. segact mmode1
  499. n1 = mmode1.kmodel(/1)
  500. imode1 = mmode1.kmodel(1)
  501. segact imode1
  502. char1(1:LCONMO) = imode1.conmod
  503. segdes imode1
  504. IF (n1.gt.1) THEN
  505. DO ikmo = 2,n1
  506. imode2 = mmode1.kmodel(ikmo)
  507. segact imode2
  508. IF (char1(1:LCONMO).ne.imode2.conmod(1:LCONMO)) THEN
  509. segdes imode2
  510. CALL erreur(732)
  511. RETURN
  512. ENDIF
  513. segdes imode2
  514. ENDDO
  515. ENDIF
  516. segini,mmodel = mmode1
  517. CALL LIRCHA(CHAR,1,LCHAR)
  518. IF (IERR.NE.0) RETURN
  519. DO ikmo = 1,n1
  520. imode1 = kmodel(ikmo)
  521. segini,imodel = imode1
  522. NFOR=FORMOD(/2)
  523. C CAS DARCY OU NAVIER ON OUBLIE LA TABLE DE PRECONDITIONNEMENT
  524. CALL PLACE (FORMOD,NFOR,IDARC,'DARCY')
  525. CALL PLACE (FORMOD,NFOR,IEULE,'EULER')
  526. CALL PLACE (FORMOD,NFOR,INAVI,'NAVIER_STOKES')
  527. IF((IDARC.NE.0).OR.(INAVI.NE.0).OR.(IEULE.NE.0)) INFMOD(2)=0
  528. kmodel(ikmo) = imodel
  529. conmod = char
  530. segdes imodel
  531. ENDDO
  532. segdes mmodel
  533. ipoi1 = mmodel
  534. CALL ecrobj('MMODEL ',ipoi1)
  535. RETURN
  536. ENDIF
  537. C
  538. C CHANGEMENT D UNE RIGIDITE CREE PAR RELATION
  539. C EN MATRICE DE DEPENDANCE OU DE CONDENSATION
  540. C
  541. 1500 CALL LIROBJ('RIGIDITE',IRIG,1,iret)
  542. IF (IERR.NE.0) RETURN
  543.  
  544. C verification que la rigidité ne contient que des relation
  545. C c'est à dire n'est supportée que par des maillage de type 22
  546. C
  547. MRIGID = IRIG
  548. SEGACT, MRIGID*NOMOD
  549. DO 1510 I=1,IRIGEL(/2)
  550. MELEME = IRIGEL(1,I)
  551. SEGACT , MELEME*NOMOD
  552. IF (ITYPEL.NE.22) THEN
  553. CALL ERREUR(889)
  554. SEGDES MELEME
  555. SEGDES MRIGID
  556. RETURN
  557. ENDIF
  558. segdes meleme
  559. 1510 CONTINUE
  560. C
  561. C matrice de depedence
  562. MRIGID = IRIG
  563. SEGACT MRIGID
  564. segini , ri1=MRIGID
  565. iri1 = ri1
  566. C nrige=8
  567. nrigel=irigel(/2)
  568. segadj ri1
  569. DO 1520 i=1,nrigel
  570. ri1.irigel(8,i)=1
  571. 1520 CONTINUE
  572. segdes mrigid,ri1
  573. C
  574. IF(iplac.eq.17) THEN
  575. CALL ecrobj('RIGIDITE',iri1)
  576. ELSE
  577. CALL depen3(iri1,iri2)
  578. CALL dual00(iri2,iri3)
  579. CALL ecrobj('RIGIDITE',iri3)
  580. CALL ecrobj('RIGIDITE',iri2)
  581. ENDIF
  582. RETURN
  583. c
  584. 1600 CALL nomc
  585. RETURN
  586.  
  587. C
  588. C CHANGEMENT DE NOM D'INCONNUES PRIMALE ET DUALE D'UNE MATRICE
  589. C
  590. 1700 CONTINUE
  591. CALL LIROBJ('MATRIK ',IPO1,0,IRETOU)
  592. IF (IRETOU.NE.0) THEN
  593. CALL REFUS
  594. CALL MACHIN
  595. RETURN
  596. ENDIF
  597. C lecture du mot cle COMPLEXE ou REEL ou rien
  598. CALL LIRMOT(LISCOM,2,ival,0)
  599. CALL lirobj('RIGIDITE',RI1,1,iretou)
  600. IF( ierr.ne.0) RETURN
  601. IF(IIMPI.ge.3) write(IOIMP,*) '>>> CHAN INCO de ',RI1,' <<<'
  602.  
  603. c ---Cas de 4 LISTMOTS---
  604. IF(IVAL.EQ.0 )THEN
  605. CALL lirobj('LISTMOTS',mlmot1,1,iretou)
  606. IF(ierr.ne.0) RETURN
  607. CALL lirobj('LISTMOTS',mlmot2,1,iretou)
  608. IF( ierr.ne.0) RETURN
  609. CALL lirobj('LISTMOTS',mlmot3,1,iretou)
  610. IF( ierr.ne.0) RETURN
  611. CALL lirobj('LISTMOTS',mlmot4,1,iretou)
  612. IF( ierr.ne.0) RETURN
  613. C lecture de la nature SYME ANTI ...
  614. IPLAMA=0
  615. CALL LIRMOT(LISMAT,3,IPLAMA,0)
  616. C lecture du mot cle MULT ou DUPL (ou rien)
  617. CALL LIRMOT(LISMUL,2,IPLMUL,0)
  618. C
  619. segact mlmot1,mlmot2,mlmot3,mlmot4
  620. il1=mlmot1.mots(/2)
  621. il2=mlmot2.mots(/2)
  622. il3=mlmot3.mots(/2)
  623. il4=mlmot4.mots(/2)
  624. IF(il1.ne.il2.or.il3.ne.il4) THEN
  625. CALL erreur(854)
  626. segdes mlmot1,mlmot2,mlmot3,mlmot4
  627. ENDIF
  628. IF(IIMPI.ge.3) write(IOIMP,*) 'cas de 4 LISTMOTS fournis'
  629.  
  630. c ---Cas COMPLEXE/REEL---
  631. ELSE
  632. JGN=4
  633. JGM=lnomdd
  634. segini mlmot1,mlmot2,mlmot3,mlmot4
  635. DO jkl=1,lnomdd
  636. mlmot1.mots(jkl)=nomdd(jkl)
  637. mlmot2.mots(jkl)(1:1)='I'
  638. mlmot2.mots(jkl)(2:4)=nomdd(jkl)(1:3)
  639. mlmot3.mots(jkl)=nomdu(jkl)
  640. mlmot4.mots(jkl)(1:1)='I'
  641. mlmot4.mots(jkl)(2:4)=nomdu(jkl)(1:3)
  642. ENDDO
  643. IF(IIMPI.ge.3) write(IOIMP,*) 'cas COMPLEXE/REEL'
  644. ENDIF
  645.  
  646. C Creation du MRIGID de sortie = presque copie de l entree
  647. segini,mrigid=ri1
  648. ichole=0
  649. imgeo1=0
  650. imgeo2=0
  651. isupeq=0
  652. jrcond=0
  653. jrdepp=0
  654. jrdepd=0
  655. jrelim=0
  656. jrgard=0
  657. jrtot=0
  658. DO 1701 k=1,irigel(/2)
  659. IF (IPLAMA.EQ.1) THEN
  660. irigel(7,k) = 0
  661. ELSEIF (IPLAMA.EQ.2) THEN
  662. irigel(7,k) = 1
  663. ELSEIF (IPLAMA.EQ.3.OR.IPLAMA.EQ.0) THEN
  664. irigel(7,k) = 2
  665. ENDIF
  666.  
  667. c creation et modif du DESCR
  668. des1=irigel(3,k)
  669. segini,descr=des1
  670. irigel(3,k)=descr
  671. nbinc=lisinc(/2)
  672. nbdua=lisdua(/2)
  673. DO 1702 ka=1,nbinc
  674. IF(lisinc(ka).EQ.'LX '.and.iplmul.eq.0) go to 1702
  675. DO 1703 kb=1,il1
  676. IF( lisinc(ka).eq.mlmot1.mots(kb) ) THEN
  677. lisinc(ka)=mlmot2.mots(kb)
  678. go to 1702
  679. ENDIF
  680. 1703 CONTINUE
  681. 1702 CONTINUE
  682. DO 1704 ka=1,nbdua
  683. IF( lisdua(ka).eq.'FLX '.and.iplmul.eq.0) go to 1704
  684. DO 1705 kb=1,il3
  685. IF( lisdua(ka).eq.mlmot3.mots(kb) ) THEN
  686. lisdua(ka)=mlmot4.mots(kb)
  687. go to 1704
  688. ENDIF
  689. 1705 CONTINUE
  690. 1704 CONTINUE
  691.  
  692. C on teste si c'est un LX : si oui, on crée un nouveau noeud
  693. C rem : on suppose qu'il n y a qu'1 LX par matrice et a une
  694. C position quelconque
  695. IF(iplmul.lt.2) goto 1706
  696. DO 1707 ka=1,min(nbinc,nbdua)
  697. IF (lisinc(ka).eq.'LX '.and.lisdua(ka).eq.'FLX ') THEN
  698. IF(IIMPI.ge.3) write(IOIMP,*) 'creation de nouveaux noeuds LX'
  699. c IF(IIMPI.ge.3) THEN
  700. c write(IOIMP,*) 'mlmot1=',(mlmot1.mots(iou),iou=1,il1)
  701. c write(IOIMP,*) 'mlmot2=',(mlmot2.mots(iou),iou=1,il2)
  702. c write(IOIMP,*) 'mlmot3=',(mlmot3.mots(iou),iou=1,il3)
  703. c write(IOIMP,*) 'mlmot4=',(mlmot4.mots(iou),iou=1,il4)
  704. c write(IOIMP,*) 'lisinc=',(lisinc(iou),iou=1,nbinc)
  705. c write(IOIMP,*) 'lisdua=',(lisdua(iou),iou=1,nbdua)
  706. c ENDIF
  707. ipt1=irigel(1,k)
  708. segini,meleme=ipt1
  709. irigel(1,k)=meleme
  710. C segact,MCOORD
  711. NBPTS=XCOOR(/1)/(IDIM+1)
  712. inp=NOELEP(ka)
  713. DO 1708 iel=1,num(/2)
  714. NBPTS=NBPTS + 1
  715. num(inp,iel)=NBPTS
  716. 1708 CONTINUE
  717. segadj,MCOORD
  718. segdes,meleme
  719. ENDIF
  720. 1707 CONTINUE
  721. 1706 CONTINUE
  722. segdes descr
  723. 1701 CONTINUE
  724. segdes mrigid
  725. IF(ival.eq.0) THEN
  726. segdes mlmot1,mlmot2,mlmot3,mlmot4
  727. ELSE
  728. segsup mlmot1,mlmot2,mlmot3,mlmot4
  729. ENDIF
  730. CALL ecrobj('RIGIDITE',mrigid)
  731. RETURN
  732. C
  733. C changement de presentation d'un chargement
  734. C mise sous forme table de chpoint (plus rapide pour l'opérateur TIRE)
  735. C
  736. 2100 CALL chatab
  737. RETURN
  738. C
  739. C Changement de la casse d'un mot
  740. C
  741. 2200 CONTINUE
  742. ICASS=IPLAC-22
  743. CALL LIRCHA(MENT,1,LENT)
  744. IF (IERR.NE.0) RETURN
  745. CALL CHCASS(MENT(1:LENT),ICASS,MSOR(1:LENT))
  746. CALL ECRCHA(MSOR(1:LENT))
  747. RETURN
  748.  
  749. 3000 CONTINUE
  750.  
  751. CALL QUETYP(CHAR8,1,IRET)
  752. IF (CHAR8.NE.'CHPOINT'.AND.CHAR8.NE.'EVOLUTIO') THEN
  753. MOTERR(1:16)='CHPOINT EVOLUTIO'
  754. CALL ERREUR(471)
  755. RETURN
  756. ENDIF
  757. C
  758. C Changement de titre d'un CHPOINT
  759. C
  760. IF (CHAR8.EQ.'CHPOINT') THEN
  761. CALL LIROBJ('CHPOINT',IP1,1,IRETOU)
  762. IF (IERR.NE.0) RETURN
  763. CALL LIRCHA(CHAR1,1,IRETOU)
  764. MCHPO1=IP1
  765. SEGINI,MCHPOI=MCHPO1
  766. MOCHDE=CHAR1
  767. SEGDES,MCHPOI
  768. CALL ECROBJ('CHPOINT',MCHPOI)
  769. C
  770. C Changement des noms d'une evolution
  771. C
  772. ELSEIF (CHAR8.EQ.'EVOLUTIO') THEN
  773. CALL LIROBJ('EVOLUTIO',IEV1,1,IRETOU)
  774. IF (IERR.NE.0) RETURN
  775. ITIT=IPLAC-23
  776. CALL LIRCHA(CHAR1,1,IRETOU)
  777. IF (IERR.NE.0) RETURN
  778. K=0
  779. CALL LIRENT(K,0,IRETOU)
  780. CALL CHEVOL(IEV1,ITIT,K,CHAR1,IEV2)
  781. CALL ECROBJ('EVOLUTIO',IEV2)
  782. ENDIF
  783.  
  784. RETURN
  785. END
  786.  
  787.  
  788.  

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