Télécharger prchan.eso

Retour à la liste

Numérotation des lignes :

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

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