Télécharger prchan.eso

Retour à la liste

Numérotation des lignes :

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

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