Télécharger prchan.eso

Retour à la liste

Numérotation des lignes :

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

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