Télécharger soravs.eso

Retour à la liste

Numérotation des lignes :

  1. C SORAVS SOURCE JC220346 12/06/18 21:15:17 7403
  2. SUBROUTINE SORAVS
  3. ************************************************************************
  4. * NOM : soravs.eso
  5. * DESCRIPTION : Sortie d'un CHPOINT et/ou d'un MCHAML (s'appuyant au
  6. C centres de gravité des éléments) avec le maillage
  7. C support au format AVS (Unstructured Cell Data, ASCII)
  8. ************************************************************************
  9. * HISTORIQUE : 25/11/1994 : BULIK : création de la subroutine
  10. * HISTORIQUE : 22/09/1995 : BULIK : ajout des options SUIT et TEMP
  11. * HISTORIQUE : 21/12/1998 : COURTOIS : modif des sorties pour maillage
  12. * HISTORIQUE : 12/02/2010 : GOUNAND : evite l'impression de *******
  13. * HISTORIQUE : 7/06/2012 : JCARDO : ajout de l'extension .inp
  14. * + fermeture du fichier
  15. * HISTORIQUE :
  16. ************************************************************************
  17. * Prière de PRENDRE LE TEMPS DE COMPLÉTER LES COMMENTAIRES
  18. * en cas de modification de ce sous-programme afin de faciliter
  19. * la maintenance !
  20. ************************************************************************
  21. * APPELÉ PAR : opérateur SORTir (prsort.eso)
  22. ************************************************************************
  23. * ENTRÉES :: aucune
  24. * SORTIES :: aucune (sur fichier uniquement)
  25. ************************************************************************
  26. * SYNTAXE (GIBIANE) :
  27. *
  28. * SORT 'AVS' (MAIL1) (CHPO1) (CHML1) ('SUIT') ('TEMP' FLOT1) ;
  29. *
  30. ************************************************************************
  31. IMPLICIT INTEGER(I-N)
  32. PARAMETER(NBMCLE=2)
  33. CHARACTER*4 MTSCLE(NBMCLE)
  34.  
  35.  
  36. -INC PPARAM
  37. -INC CCOPTIO
  38. -INC SMCOORD
  39. -INC SMELEME
  40. -INC SMCHPOI
  41. -INC SMCHAML
  42. -INC SMLMOTS
  43.  
  44. EXTERNAL LONG
  45.  
  46. POINTEUR MAPOIN.MELEME, MAELEM.MELEME
  47. POINTEUR IPT10.MELEME, IPT11.MELEME
  48.  
  49. POINTEUR NCMCHA.MLMOTS, NCCHPO.MLMOTS
  50.  
  51. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  52. C
  53. SEGMENT VALMCH
  54. REAL*8 RVAMCH(NBCMCH,NELMAI)
  55. END SEGMENT
  56. C
  57. C Segment : VALeurs du MCHaml
  58. C
  59. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  60.  
  61. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  62. C
  63. SEGMENT VALCHP
  64. REAL*8 RVACHP(NBCCHP,NBNMAP)
  65. END SEGMENT
  66. C
  67. C Segment : VALeurs du CHPoint
  68. C
  69. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  70.  
  71. SEGMENT IEQUIV
  72. INTEGER LEQUIV(IECART)
  73. END SEGMENT
  74.  
  75. CHARACTER*8 MTYP
  76. CHARACTER*4 NOM4
  77.  
  78. REAL*8 VALTEM
  79.  
  80. LOGICAL SORMAI, SORCHP, SORMCH, EXISEL, CNDTN
  81.  
  82. LOGICAL CMPINT
  83. EXTERNAL CMPINT
  84.  
  85. DATA MTSCLE/'SUIT','TEMP'/
  86.  
  87. CHARACTER*256 FICAVS
  88. LOGICAL ZOPEN
  89.  
  90. NCCHPO=0
  91. NCMCHA=0
  92. VALCHP=0
  93. VALMCH=0
  94. IEQUIV=0
  95.  
  96. SORMAI=.FALSE.
  97. SORCHP=.FALSE.
  98. SORMCH=.FALSE.
  99.  
  100. C ... Recherche des objets à sortir ...
  101.  
  102. CALL LIROBJ('MAILLAGE',IVAL,0,IRETOU)
  103. IF(IRETOU.EQ.1) THEN
  104.  
  105. MELEME=IVAL
  106. SORMAI=.TRUE.
  107.  
  108. MAELEM=MELEME
  109. EXISEL=.TRUE.
  110.  
  111. MAPOIN=MAELEM
  112. CALL CHANGE(MAPOIN,1)
  113. C ... Attention ! MAPOIN est déjà actif (voir CHANGE) ...
  114.  
  115. ENDIF
  116.  
  117. CALL LIROBJ('MCHAML ',IVAL,0,IRETOU)
  118. IF(IRETOU.EQ.1) THEN
  119.  
  120. MCHELM=IVAL
  121. SORMCH=.TRUE.
  122.  
  123. IF(.NOT.SORMAI) THEN
  124. CALL ECRCHA('MAIL')
  125. CALL ECROBJ('MCHAML ',MCHELM)
  126. CALL EXTRAI
  127. CALL LIROBJ('MAILLAGE',MAELEM,1,IRETOU)
  128. IF(IERR.NE.0) GOTO 9999
  129. EXISEL=.TRUE.
  130.  
  131. MAPOIN=MAELEM
  132. CALL CHANGE(MAPOIN,1)
  133. C ... Attention ! MAPOIN est déjà actif (voir CHANGE) ...
  134. ENDIF
  135.  
  136. ENDIF
  137.  
  138. CALL LIROBJ('CHPOINT ',IVAL,0,IRETOU)
  139. IF(IRETOU.EQ.1) THEN
  140. MCHPOI=IVAL
  141. SORCHP=.TRUE.
  142.  
  143. IF((.NOT.SORMAI).AND.(.NOT.SORMCH)) THEN
  144. MAELEM=0
  145. EXISEL=.FALSE.
  146.  
  147. CALL ECRCHA('MAIL')
  148. CALL ECROBJ('CHPOINT ',MCHPOI)
  149. CALL EXTRAI
  150. CALL LIROBJ('MAILLAGE',MAPOIN,1,IRETOU)
  151. IF(IERR.NE.0) GOTO 9999
  152. SEGACT MAPOIN
  153. ENDIF
  154.  
  155. ENDIF
  156.  
  157. IF((.NOT.SORMAI).AND.(.NOT.SORMCH).AND.(.NOT.SORCHP)) THEN
  158. CALL ERREUR(704)
  159. RETURN
  160. ENDIF
  161.  
  162. C ... Lecture des mots clés éventuels ...
  163.  
  164. NBCGLO=0
  165. INOREW=0
  166.  
  167. 10 CALL LIRMOT(MTSCLE,NBMCLE,IRAN,0)
  168.  
  169. IF(IRAN.EQ.1) INOREW=1
  170.  
  171. IF(IRAN.EQ.2) THEN
  172. NBCGLO=1
  173. CALL LIRREE(VALTEM,1,IRETOU)
  174. IF(IERR.NE.0) GOTO 9999
  175. cdebug write(*,*) 'Le temps lu = ',VALTEM
  176. ENDIF
  177.  
  178. IF(IRAN.NE.0) GOTO 10
  179.  
  180. C ... NELMAI = Nombre d'ÉLéments du MAIllage ...
  181. IF(EXISEL) THEN
  182. CALL ECROBJ('MAILLAGE',MAELEM)
  183. CALL NBEL
  184. CALL LIRENT(NELMAI,1,IRETOU)
  185. IF(IERR.NE.0) GOTO 9999
  186. ELSE
  187. NELMAI=0
  188. ENDIF
  189.  
  190. C ... NBNMAP = NomBre de Noeuds du MAPoin ...
  191. CALL ECROBJ('MAILLAGE',MAPOIN)
  192. CALL NBNO
  193. CALL LIRENT(NBNMAP,1,IRETOU)
  194. IF(IERR.NE.0) GOTO 9999
  195.  
  196. C ... Si le MAILLAGE et le MCHAML sont donnés, on vérifiera que le
  197. C MAILLAGE est un sous-ensemble du support du MCHAML ...
  198.  
  199. IF(SORMAI.AND.SORMCH) THEN
  200.  
  201. C ... IPT1 = support du MCHAML ...
  202. CALL ECRCHA('MAIL')
  203. CALL ECROBJ('MCHAML ',MCHELM)
  204. CALL EXTRAI
  205. CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  206. IF(IERR.NE.0) GOTO 9999
  207.  
  208. CALL ECROBJ('MAILLAGE',IPT1)
  209. CALL NBEL
  210. CALL LIRENT(NELSMC,1,IRETOU)
  211. IF(IERR.NE.0) GOTO 9999
  212.  
  213. C ... IPT2 = intersection du MAILLAGE et du support du MCHAML ...
  214. C Si les deux sont distincts, INTERS sortira une ERREUR,
  215. C on commence donc par une différence symétrique :
  216. C si sa taille = NELMAI + NELSMC, ils sont distincts ...
  217. C ... Le problème est que lorsque les deux sont égaux, PRDIFF
  218. C se plante car il ne veut pas sortir un maillage nul,
  219. C il lui manque une option NOVERIF. On commence donc par vérifier
  220. C si les deux nombres d'éléments sont égaux - si OUI, un danger
  221. C guette, on va donc regarder ça de plus près, sinon PRDIFF etc ...
  222. C ... CNDTN est un logique qui décrit l'égalité des deux maillages ...
  223. IF(NELMAI.EQ.NELSMC) THEN
  224. SEGACT MAELEM
  225. SEGACT IPT1
  226. NBEL1=MAELEM.NUM(/2)
  227. NBEL2= IPT1.NUM(/2)
  228. IF(NBEL1.EQ.NBEL2 .AND. NBEL1.GT.0) THEN
  229. C ... Le cas où les deux maillages sont simples ...
  230. NBNN1=MAELEM.NUM(/1)
  231. NBNN2= IPT1.NUM(/1)
  232. IF((NBNN1.EQ.NBNN2).AND.(MAELEM.ITYPEL.EQ.IPT1.ITYPEL))
  233. & THEN
  234. ILONG=NBEL1*NBNN1
  235. CNDTN=CMPINT(MAELEM.NUM(1,1),IPT1.NUM(1,1),ILONG)
  236. ELSE
  237. CNDTN=.FALSE.
  238. ENDIF
  239. ELSE IF(NBEL1.EQ.NBEL2 .AND. NBEL1.EQ.0) THEN
  240. C ... Le cas où les deux maillages sont composés ...
  241. NBS1=MAELEM.LISOUS(/1)
  242. NBS2= IPT1.LISOUS(/1)
  243. IF(NBS1.EQ.NBS2) THEN
  244. CNDTN=.TRUE.
  245. DO 1100 I=1,NBS1
  246. IPT10=MAELEM.LISOUS(I)
  247. IPT11= IPT1.LISOUS(I)
  248. SEGACT IPT10
  249. SEGACT IPT11
  250. IF((IPT10.NUM(/1).EQ.IPT11.NUM(/1)) .AND.
  251. & (IPT10.NUM(/2).EQ.IPT11.NUM(/2)) .AND.
  252. & (IPT10.ITYPEL .EQ.IPT11.ITYPEL) ) THEN
  253. ILONG=IPT10.NUM(/1)*IPT10.NUM(/2)
  254. CNDTN=CNDTN.AND.CMPINT(IPT10.NUM(1,1),
  255. & IPT11.NUM(1,1),ILONG)
  256. ELSE
  257. CNDTN=.FALSE.
  258. ENDIF
  259. SEGDES IPT10
  260. SEGDES IPT11
  261. 1100 CONTINUE
  262. ELSE
  263. CNDTN=.FALSE.
  264. ENDIF
  265. ELSE
  266. C ... Dans le cas où NBEL1 n'est pas egal à NBEL2 il est peu
  267. C probable quoique pas exclu que les deux maillages soient
  268. C égaux, on met donc CoNDiTioN à FAUX ...
  269. CNDTN=.FALSE.
  270. ENDIF
  271. SEGDES MAELEM
  272. SEGDES IPT1
  273. ELSE
  274. CNDTN=.FALSE.
  275. ENDIF
  276.  
  277. IF(CNDTN) THEN
  278. NELDS=0
  279. ELSE
  280. CALL ECROBJ('MAILLAGE',MAELEM)
  281. CALL ECROBJ('MAILLAGE',IPT1)
  282. CALL PRDIFF
  283. CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
  284. IF(IERR.NE.0) GOTO 9999
  285.  
  286. CALL ECROBJ('MAILLAGE',IPT2)
  287. CALL NBEL
  288. CALL LIRENT(NELDS,1,IRETOU)
  289. IF(IERR.NE.0) GOTO 9999
  290. ENDIF
  291.  
  292. IF(NELDS.EQ.NELMAI+NELSMC) THEN
  293. IPT2=0
  294. NELINT=0
  295. ELSE
  296. CALL ECROBJ('MAILLAGE',MAELEM)
  297. CALL ECROBJ('MAILLAGE',IPT1)
  298. CALL INTERS
  299. CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
  300. IF(IERR.NE.0) GOTO 9999
  301.  
  302. C ... NELINT = nombre d'éléments de l'INTersection IPT2 ...
  303. CALL ECROBJ('MAILLAGE',IPT2)
  304. CALL NBEL
  305. CALL LIRENT(NELINT,1,IRETOU)
  306. IF(IERR.NE.0) GOTO 9999
  307. ENDIF
  308.  
  309. C ... S'il n'y pas égalité, MAILLAGE n'est pas un sous ensemble ...
  310. IF(NELINT.NE.NELMAI) THEN
  311. CALL ERREUR(706)
  312. GOTO 10000
  313. ENDIF
  314.  
  315. C ... Maintenant on réduit le MCHAML su MELEME pour être sûr de
  316. C l'ordre des éléments ...
  317. CALL REDUIC(MCHELM,MELEME,IRETOU)
  318. IF(IRETOU.EQ.0) THEN
  319. GOTO 9999
  320. ELSE
  321. MCHELM=IRETOU
  322. ENDIF
  323.  
  324. C ... Maintenant MCHELM est consistant avec MAELEM et MAPOIN ...
  325. C ... Il reste deux maillages comme effet (IPT1, IPT2) ...
  326.  
  327. ENDIF
  328.  
  329. C ... Si le MAILLAGE (ou MCHAML) et le CHPOINT sont présents, on vérifiera que
  330. C le MAILLAGE et le support du CHPOINT ont une partie commune ...
  331.  
  332. IF((SORMAI.OR.SORMCH).AND.SORCHP) THEN
  333.  
  334. C ... IPT3 = support du CHPOINT ...
  335. CALL ECRCHA('MAIL')
  336. CALL ECROBJ('CHPOINT ',MCHPOI)
  337. CALL EXTRAI
  338. CALL LIROBJ('MAILLAGE',IPT3,1,IRETOU)
  339. IF(IERR.NE.0) GOTO 9999
  340.  
  341. C ... NNSCHP = Nombre de Noeuds du Support du CHPoint ...
  342. CALL ECROBJ('MAILLAGE',IPT3)
  343. CALL NBNO
  344. CALL LIRENT(NNSCHP,1,IRETOU)
  345. IF(IERR.NE.0) GOTO 9999
  346.  
  347. C ... Pour les explications de cette partie voir la partie
  348. C équivalente ci-dessus, au niveau du traitement du MCHAML ...
  349. IF(NBNMAP.EQ.NNSCHP) THEN
  350. SEGACT MAPOIN
  351. SEGACT IPT3
  352. NBEL1=MAPOIN.NUM(/2)
  353. NBEL2= IPT3.NUM(/2)
  354. IF(NBEL1.EQ.NBEL2 .AND. NBEL1.GT.0) THEN
  355. C ... Le cas où les deux maillages sont simples ...
  356. NBNN1=MAPOIN.NUM(/1)
  357. NBNN2= IPT3.NUM(/1)
  358. IF((NBNN1.EQ.NBNN2).AND.(MAPOIN.ITYPEL.EQ.IPT3.ITYPEL))
  359. & THEN
  360. ILONG=NBEL1*NBNN1
  361. CNDTN=CMPINT(MAPOIN.NUM(1,1),IPT3.NUM(1,1),ILONG)
  362. ELSE
  363. CNDTN=.FALSE.
  364. ENDIF
  365. ELSE IF(NBEL1.EQ.NBEL2 .AND. NBEL1.EQ.0) THEN
  366. C ... Le cas où les deux maillages sont composés ...
  367. NBS1=MAPOIN.LISOUS(/1)
  368. NBS2= IPT3.LISOUS(/1)
  369. IF(NBS1.EQ.NBS2) THEN
  370. CNDTN=.TRUE.
  371. DO 1200 I=1,NBS1
  372. IPT10=MAPOIN.LISOUS(I)
  373. IPT11= IPT3.LISOUS(I)
  374. SEGACT IPT10
  375. SEGACT IPT11
  376. IF((IPT10.NUM(/1).EQ.IPT11.NUM(/1)) .AND.
  377. & (IPT10.NUM(/2).EQ.IPT11.NUM(/2)) .AND.
  378. & (IPT10.ITYPEL .EQ.IPT11.ITYPEL) ) THEN
  379. ILONG=IPT10.NUM(/1)*IPT10.NUM(/2)
  380. CNDTN=CNDTN.AND.CMPINT(IPT10.NUM(1,1),
  381. & IPT11.NUM(1,1),ILONG)
  382. ELSE
  383. CNDTN=.FALSE.
  384. ENDIF
  385. SEGDES IPT10
  386. SEGDES IPT11
  387. 1200 CONTINUE
  388. ELSE
  389. CNDTN=.FALSE.
  390. ENDIF
  391. ELSE
  392. C ... Dans le cas où NBEL1 n'est pas egal à NBEL2 il est peu
  393. C probable quoique pas exclu que les deux maillages soient
  394. C égaux, on met donc CoNDiTioN à FAUX ...
  395. CNDTN=.FALSE.
  396. ENDIF
  397. SEGDES MAPOIN
  398. SEGDES IPT3
  399. ELSE
  400. CNDTN=.FALSE.
  401. ENDIF
  402.  
  403. IF(CNDTN) THEN
  404. NNDS=0
  405. ELSE
  406. C ... IPT4 = ici à la différence symétrique du MAPOIN et du support du CHPOINT ...
  407. CALL ECROBJ('MAILLAGE',MAPOIN)
  408. CALL ECROBJ('MAILLAGE',IPT3)
  409. CALL PRDIFF
  410. CALL LIROBJ('MAILLAGE',IPT4,1,IRETOU)
  411. IF(IERR.NE.0) GOTO 9999
  412.  
  413. CALL ECROBJ('MAILLAGE',IPT4)
  414. CALL NBNO
  415. CALL LIRENT(NNDS,1,IRETOU)
  416. IF(IERR.NE.0) GOTO 9999
  417. ENDIF
  418.  
  419. C ... IPT4 = intersection du MAPOIN et du support du CHPOINT ...
  420. IF(NNDS.EQ.NBNMAP+NNSCHP) THEN
  421. IPT4=0
  422. NBNIN4=0
  423. ELSE
  424. CALL ECROBJ('MAILLAGE',MAPOIN)
  425. CALL ECROBJ('MAILLAGE',IPT3)
  426. CALL INTERS
  427. CALL LIROBJ('MAILLAGE',IPT4,1,IRETOU)
  428. IF(IERR.NE.0) GOTO 9999
  429.  
  430. C ... NBNIN4 = NomBre de Noeuds de l'INtersection ipt4 ...
  431. CALL ECROBJ('MAILLAGE',IPT4)
  432. CALL NBNO
  433. CALL LIRENT(NBNIN4,1,IRETOU)
  434. IF(IERR.NE.0) GOTO 9999
  435. ENDIF
  436.  
  437. IF(NBNIN4.EQ.0) THEN
  438. C ... Quand NBNIN4=0 -> cas No 1 ...
  439. SORCHP=.FALSE.
  440. CALL ERREUR(-297)
  441. CALL ERREUR(-296)
  442. ELSE IF(NBNIN4.EQ.NBNMAP) THEN
  443. C ... Si NBNIN4=NBNMAP (cas 2), il faut réduire le CHPOINT sur le maillage ...
  444. CALL REDUIR(MCHPOI,MAPOIN,IRETOU)
  445. IF(IRETOU.EQ.0) THEN
  446. GOTO 9999
  447. ELSE
  448. MCHPOI=IRETOU
  449. ENDIF
  450. ELSE IF (NBNIN4.EQ.NNSCHP) THEN
  451. C ... Cas No 4 - le support du CHPOINT est entièrement contenu dans le
  452. C maillage, donc on ne fait rien ...
  453. ELSE
  454. C ... Sinon, c'est le cas 3, il faut donc "aggrandir" le CHPOINT,
  455. C en fait on va le réduire sur l'intersection IPT4, ceci pour
  456. C éliminer les composantes dont le support est en dehors du maillage ...
  457. CALL REDUIR(MCHPOI,IPT4,IRETOU)
  458. IF(IRETOU.EQ.0) THEN
  459. GOTO 9999
  460. ELSE
  461. MCHPOI=IRETOU
  462. ENDIF
  463. ENDIF
  464.  
  465. ENDIF
  466.  
  467. C ... Puisqu'on ne sort que certains noeuds il faut transformer les
  468. C connectivités, pour ceci on se servira du SEGMENT IEQUIV ...
  469.  
  470. C ... Recherche des numéros maxi et mini des noeuds dont on a besoin ...
  471.  
  472. SEGACT MAPOIN
  473. NBELEM=MAPOIN.NUM(/2)
  474. NBNN=MAPOIN.NUM(/1)
  475. IF(NBELEM.EQ.NBNMAP) THEN
  476.  
  477. IF(NBNN.NE.1) GOTO 9999
  478. IPTMIN=MAPOIN.NUM(1,1)
  479. IPTMAX=MAPOIN.NUM(1,1)
  480. DO 1500 I=1,NBELEM
  481. IF(MAPOIN.NUM(1,I).LT.IPTMIN) IPTMIN=MAPOIN.NUM(1,I)
  482. IF(MAPOIN.NUM(1,I).GT.IPTMAX) IPTMAX=MAPOIN.NUM(1,I)
  483. 1500 CONTINUE
  484.  
  485. ELSE IF(NBELEM.EQ.0) THEN
  486.  
  487. NBSOUS=MAPOIN.LISOUS(/1)
  488. DO 1505 I=1,NBSOUS
  489. IPT5=LISOUS(I)
  490. SEGACT IPT5
  491. NBNTMP=IPT5.NUM(/1)
  492. NBETMP=IPT5.NUM(/2)
  493. IF(NBNTMP.NE.1) GOTO 9999
  494. IF(I.EQ.1) THEN
  495. IPTMIN=IPT5.NUM(1,1)
  496. IPTMAX=IPT5.NUM(1,1)
  497. ENDIF
  498. DO 1506 J=1,NBETMP
  499. IF(IPT5.NUM(1,J).LT.IPTMIN) IPTMIN=IPT5.NUM(1,J)
  500. IF(IPT5.NUM(1,J).GT.IPTMAX) IPTMAX=IPT5.NUM(1,J)
  501. 1506 CONTINUE
  502. SEGDES IPT5
  503. 1505 CONTINUE
  504.  
  505. ENDIF
  506.  
  507. C ... Initialisation du segment IEQUIV ...
  508.  
  509. IECART=IPTMAX-IPTMIN+1
  510. SEGINI IEQUIV
  511.  
  512. C ... et son remplissage ...
  513.  
  514. IF(NBELEM.EQ.NBNMAP) THEN
  515.  
  516. DO 1510 I=1,NBELEM
  517. LEQUIV(MAPOIN.NUM(1,I)-IPTMIN+1)=I
  518. 1510 CONTINUE
  519.  
  520. ELSE IF(NBELEM.EQ.0) THEN
  521.  
  522. NBSOUS=MAPOIN.LISOUS(/1)
  523. K=0
  524. DO 1515 I=1,NBSOUS
  525. IPT5=LISOUS(I)
  526. SEGACT IPT5
  527. NBNTMP=IPT5.NUM(/1)
  528. NBETMP=IPT5.NUM(/2)
  529. IF(NBNTMP.NE.1) GOTO 9999
  530. DO 1516 J=1,NBETMP
  531. K=K+1
  532. C ... Ici je suppose que chaque point n'est représenté qu'une
  533. C seule fois dans MAPOIN. En conséquence, dans la ligne en dessous
  534. C je n'ai pas mis de test si LEQUIV(IPT5.NUM(1,J)-IPTMIN+1) est
  535. C différent de zéro ...
  536. LEQUIV(IPT5.NUM(1,J)-IPTMIN+1)=K
  537. 1516 CONTINUE
  538. SEGDES IPT5
  539. 1515 CONTINUE
  540.  
  541. ENDIF
  542.  
  543. C ... Préparation de la première ligne du fichier AVS, on connaît déjà
  544. C les nombres de noeuds et d'éléments, il manque les nombres de composantes
  545. C du CHPOINT et du MCHAML (s'ils sont présents) ...
  546.  
  547. C ... On commence par le MCHAML ...
  548. IF(SORMCH) THEN
  549. CALL EXTR17(MCHELM,NCMCHA)
  550. SEGACT NCMCHA
  551. NBCMCH=NCMCHA.MOTS(/2)
  552. ccc SEGDES NCMCHA
  553. ELSE
  554. NBCMCH=0
  555. ENDIF
  556.  
  557. C ... Et ensuite c'est le tour du CHPOINT ...
  558. IF(SORCHP) THEN
  559. CALL EXTR11(MCHPOI,NCCHPO)
  560. SEGACT NCCHPO
  561. NBCCHP=NCCHPO.MOTS(/2)
  562. ccc SEGDES NCCHPO
  563. ELSE
  564. NBCCHP=0
  565. ENDIF
  566.  
  567. C ... Maintenant on va remplir des segments contenant toutes les valeurs
  568. C et composantes du MCHAML et du CHPOINT en un seul morceau ...
  569.  
  570. C ... On commence par le MCHAML ...
  571. C ... On va vérifier aussi qu'il y a une seule valeur par élément ...
  572. IF(SORMCH) THEN
  573. C ... On ne le met pas à zero car toutes les cases vont etre remplies ...
  574. SEGINI VALMCH
  575. SEGACT MCHELM
  576. N1=ICHAML(/1)
  577. C ... IDECNE = DECalage des Numéros d'Eléments ...
  578. IDECNE=0
  579. C ... Boucle sur les zones élémentaires, dont chacune possède son ...
  580. DO 1600 I=1,N1
  581. C ... segment MCHAML ...
  582. MCHAML=ICHAML(I)
  583. SEGACT MCHAML
  584. N2=IELVAL(/1)
  585. C ... et le maillage support ...
  586. IPT6=IMACHE(I)
  587. CALL ECROBJ('MAILLAGE',IPT6)
  588. CALL NBEL
  589. CALL LIRENT(NELSMC,1,IRETOU)
  590. IF(IERR.NE.0) GOTO 9999
  591. C ... Boucle sur les composantes du MCHAML ...
  592. DO 1610 J=1,N2
  593. IF(TYPCHE(J).NE.'REAL*8 ') THEN
  594. MOTERR(1:8)=NOMCHE(J)
  595. CALL ERREUR(679)
  596. GOTO 10000
  597. ENDIF
  598. C ... Maintenant on cherche la position du nom de la composante No J
  599. C dans NCMCHA ...
  600. WRITE(NOM4,'(A4)') NOMCHE(J)
  601. DO 1620 K=1,NBCMCH
  602. IF(NCMCHA.MOTS(K).EQ.NOM4) GOTO 1630
  603. 1620 CONTINUE
  604. 1630 CONTINUE
  605. C ... K est maintenant le numéro de la composante J dans NCMCHA ...
  606. MELVAL=IELVAL(J)
  607. SEGACT MELVAL
  608. N1PTEL=VELCHE(/1)
  609. N1EL =VELCHE(/2)
  610. IF(N1PTEL.NE.1) THEN
  611. CALL ERREUR(707)
  612. GOTO 10000
  613. ENDIF
  614. C ... Si N1EL==1 c'est un champ constant ...
  615. IF(N1EL.EQ.1) THEN
  616. DO 1680 L=1,NELSMC
  617. RVAMCH(K,L+IDECNE)=VELCHE(1,1)
  618. 1680 CONTINUE
  619. ELSE IF(N1EL.EQ.NELSMC) THEN
  620. DO 1660 L=1,NELSMC
  621. RVAMCH(K,L+IDECNE)=VELCHE(1,L)
  622. 1660 CONTINUE
  623. ELSE
  624. MOTERR(1:8)='MCHAML '
  625. CALL ERREUR(708)
  626. GOTO 10000
  627. ENDIF
  628. SEGDES MELVAL
  629. 1610 CONTINUE
  630. IDECNE=IDECNE+NELSMC
  631. SEGDES MCHAML
  632. 1600 CONTINUE
  633. SEGDES MCHELM
  634. ENDIF
  635.  
  636. C ... Remplissage des valeurs du CHPOINT ...
  637. IF(SORCHP) THEN
  638.  
  639. SEGINI VALCHP
  640. CDEBUG WRITE(IOIMP,*) 'NBCCHP = ',NBCCHP
  641. CDEBUG WRITE(IOIMP,*) 'NBNMAP = ',NBNMAP
  642. DO 1700 I=1,NBCCHP
  643. DO 1700 J=1,NBNMAP
  644. RVACHP(I,J)=0.D0
  645. 1700 CONTINUE
  646.  
  647. SEGACT MCHPOI
  648. NSOUPO=IPCHP(/1)
  649. C ... IDECNP = DECalage des Numéros de Points ...
  650. C inutile IDECNP=0
  651. C ... Boucle sur les sous-zones du CHPOINT dont chacune est définie par ...
  652. DO 1710 I=1,NSOUPO
  653. C ... un segment MSOUPO ...
  654. CDEBUG WRITE(IOIMP,*) 'Sous-zone No ',I
  655. MSOUPO=IPCHP(I)
  656. SEGACT MSOUPO
  657. NC=NOHARM(/1)
  658. C ... son support géométrique ...
  659. IPT7=IGEOC
  660. CALL NOMOBJ('MAILLAGE','MASUPCHP',IPT7)
  661. CALL ECROBJ('MAILLAGE',IPT7)
  662. CALL NBNO
  663. CALL LIRENT(NPOSCH,1,IRETOU)
  664. IF(IERR.NE.0) GOTO 9999
  665. SEGACT IPT7
  666. CDEBUG WRITE(IOIMP,*) ' -> ',NPOSCH,' noeuds'
  667. CDEBUG WRITE(IOIMP,*) 'IPT7 : ITYPEL = ',IPT7.ITYPEL
  668. CDEBUG WRITE(IOIMP,*) 'IPT7 : NBELEM = ',IPT7.NUM(/2)
  669. C ... et ses valeurs ...
  670. MPOVAL=IPOVAL
  671. SEGACT MPOVAL
  672. N=VPOCHA(/1)
  673. IF(N.NE.NPOSCH) THEN
  674. MOTERR(1:8)='CHPOINT '
  675. CALL ERREUR(708)
  676. GOTO 10000
  677. ENDIF
  678. C ... Boucle sur les composantes du CHPOINT ...
  679. DO 1720 J=1,NC
  680. C ... dont on cherche la place dans NCCHPO ...
  681. WRITE(NOM4,'(A4)') NOCOMP(J)
  682. DO 1730 K=1,NBCCHP
  683. IF(NCCHPO.MOTS(K).EQ.NOM4) GOTO 1740
  684. 1730 CONTINUE
  685. 1740 CONTINUE
  686. C ... Maintenant K pointe le NOCOMP(J) dans NCCHPO ...
  687. CDEBUG WRITE(IOIMP,*) 'Composante No',J,' correspond à K = ',K
  688. C ... Maintenant il faut parcourir les noeuds du support du CHPOINT ...
  689. C ... Si ce support est un maillage élémentaire, ceci est simple ...
  690. IF(IPT7.NUM(/2).GT.0) THEN
  691. CDEBUG WRITE(IOIMP,*) 'Support = Maillage élémentaire'
  692. DO 1750 L=1,N
  693. C ... ça ne marchera pas dans le cas général, car l'ordre des n'est pas
  694. C forcément le meme dans le MAPOIN et dans le support du CHPOINT ...
  695. C RVACHP(K,L+IDECNP)=VPOCHA(L,J) ...
  696. C ... il faut chercher la position du noeud ...
  697. NNSCHP=IPT7.NUM(1,L)
  698. IF(NNSCHP.GE.IPTMIN.AND.NNSCHP.LE.IPTMAX) THEN
  699. NNMAPO=LEQUIV(NNSCHP-IPTMIN+1)
  700. ELSE
  701. NNMAPO=0
  702. ENDIF
  703. CDEBUG WRITE(IOIMP,*) 'Noeud ',L,' = ',NNSCHP,' -> NNMAPO = ',NNMAPO
  704. IF(NNMAPO.NE.0) RVACHP(K,NNMAPO)=VPOCHA(L,J)
  705. 1750 CONTINUE
  706. C ... Sinon on va s'amuser ...
  707. ELSE
  708. CDEBUG WRITE(IOIMP,*) 'Support = Maillage composé'
  709. L=0
  710. NBSOUS=IPT7.LISOUS(/1)
  711. DO 1765 M=1,NBSOUS
  712. IPT8=IPT7.LISOUS(M)
  713. SEGACT IPT8
  714. NBELEM=IPT8.NUM(/2)
  715. CDEBUG WRITE(IOIMP,*) 'IPT8 : ITYPEL = ',IPT8.ITYPEL
  716. CDEBUG WRITE(IOIMP,*) 'IPT8 : NBELEM = ',NBELEM
  717. DO 1770 MM=1,NBELEM
  718. L=L+1
  719. NNSCHP=IPT8.NUM(1,MM)
  720. IF(NNSCHP.GE.IPTMIN.AND.NNSCHP.LE.IPTMAX) THEN
  721. NNMAPO=LEQUIV(NNSCHP-IPTMIN+1)
  722. ELSE
  723. NNMAPO=0
  724. ENDIF
  725. CDEBUG WRITE(IOIMP,*) 'Noeud ',L,' = ',NNSCHP,' -> NNMAPO = ',NNMAPO
  726. IF(NNMAPO.NE.0) RVACHP(K,NNMAPO)=VPOCHA(L,J)
  727. 1770 CONTINUE
  728. SEGDES IPT8
  729. 1765 CONTINUE
  730. ENDIF
  731. 1720 CONTINUE
  732. C inutile IDECNP=IDECNP+NPOSCH
  733. SEGDES MPOVAL
  734. SEGDES MSOUPO
  735. SEGDES IPT7
  736. 1710 CONTINUE
  737. SEGDES MCHPOI
  738.  
  739. ENDIF
  740.  
  741. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  742. C ... Sortie au format AVS ...
  743. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  744.  
  745.  
  746. * Récupération du nom du fichier et ajout de l'extension au
  747. * nom du fichier
  748. INQUIRE(UNIT=IOPER,OPENED=ZOPEN)
  749. IF (.NOT.ZOPEN) THEN
  750. CALL ERREUR(-212)
  751. WRITE(IOIMP,*) '(via OPTI "SORT")'
  752. MOTERR(1:8)='AVS '
  753. CALL ERREUR(705)
  754. RETURN
  755. ENDIF
  756.  
  757. * Quel est le nom du fichier ouvert ?
  758. INQUIRE(UNIT=IOPER,NAME=NOMFIC)
  759.  
  760. * Si pas d'extention .inp, on le réouvre
  761. CALL LENCHA(NOMFIC,LC)
  762. IF (NOMFIC(LC-3:LC).NE.'.inp') THEN
  763. CLOSE(UNIT=IOPER,STATUS='DELETE')
  764. WRITE(FICAVS,FMT='(A,A4)') NOMFIC(1:LONG(NOMFIC)),'.inp'
  765. IOS=0
  766. OPEN(UNIT=IOPER,STATUS='UNKNOWN',FILE=FICAVS(1:LONG(FICAVS)),
  767. & IOSTAT=IOS,FORM='FORMATTED')
  768. ENDIF
  769.  
  770. * Pas d'option 'SUIT' => on rembobine
  771. IF (INOREW.EQ.0) REWIND IOPER
  772.  
  773. C ... Ligne de tete ...
  774. WRITE(IOPER,4000) NBNMAP,NELMAI,NBCCHP,NBCMCH,NBCGLO
  775.  
  776. C ... Les noeuds ...
  777. DO 2000 I=1,NBNMAP
  778. SEGACT MAPOIN
  779. NUMNO=MAPOIN.NUM(1,I)
  780. IF(IDIM.EQ.2) THEN
  781. WRITE(IOPER,4010) I,XCOOR((NUMNO-1)*(IDIM+1)+1),
  782. & XCOOR((NUMNO-1)*(IDIM+1)+2),
  783. & 0.D0
  784. ELSE
  785. WRITE(IOPER,4010) I,XCOOR((NUMNO-1)*(IDIM+1)+1),
  786. & XCOOR((NUMNO-1)*(IDIM+1)+2),
  787. & XCOOR((NUMNO-1)*(IDIM+1)+3)
  788. ENDIF
  789. SEGDES MAPOIN
  790. 2000 CONTINUE
  791.  
  792. C ... Le maillage ...
  793. IDECAL=0
  794. IF(EXISEL) THEN
  795. SEGACT MAELEM
  796. NBELEM=MAELEM.NUM(/2)
  797. IF(NBELEM.GT.0) THEN
  798. CALL AVSMEL(MAELEM,IDECAL,1,IEQUIV,IPTMIN)
  799. ELSE
  800. NBSOUS=MAELEM.LISOUS(/1)
  801. DO 2100 I=1,NBSOUS
  802. LESOUS=MAELEM.LISOUS(I)
  803. CALL AVSMEL(LESOUS,IDECAL,I,IEQUIV,IPTMIN)
  804. 2100 CONTINUE
  805. ENDIF
  806. SEGDES MAELEM
  807. ENDIF
  808.  
  809. C ... Le CHPOINT ...
  810. IF(SORCHP) THEN
  811. C ... On commence par les noms des composantes ...
  812. WRITE(IOPER,4030) NBCCHP,(1,K=1,NBCCHP)
  813. C+DC
  814. DO 2101 I=1,NBCCHP
  815. WRITE(IOPER,4042) (NCCHPO.MOTS(I))
  816. 2101 CONTINUE
  817. C
  818. SEGSUP NCCHPO
  819.  
  820. C ... Et ensuite leurs valeurs ...
  821. DO 2200 I=1,NBNMAP
  822. WRITE(IOPER,4050) I,(RVACHP(K,I),K=1,NBCCHP)
  823. 2200 CONTINUE
  824. SEGSUP VALCHP
  825. ENDIF
  826.  
  827. C ... Le MCHAML ...
  828. IF(SORMCH) THEN
  829. C ... On commence par les noms des composantes ...
  830. WRITE(IOPER,4030) NBCMCH,(1,K=1,NBCMCH)
  831. WRITE(IOPER,4043) (NCMCHA.MOTS(I),I=1,NBCMCH)
  832. SEGSUP NCMCHA
  833.  
  834. C ... Et ensuite leurs valeurs ...
  835. DO 2300 I=1,NELMAI
  836. WRITE(IOPER,4050) I,(RVAMCH(K,I),K=1,NBCMCH)
  837. 2300 CONTINUE
  838. SEGSUP VALMCH
  839. ENDIF
  840.  
  841. C ... Le champ global ...
  842.  
  843. IF(NBCGLO.EQ.1) THEN
  844. WRITE(IOPER,4030) 1,1
  845. WRITE(IOPER,4040) 'time'
  846. WRITE(IOPER,4050) 1,VALTEM
  847. ENDIF
  848.  
  849. C ... Le ménage ...
  850.  
  851. SEGSUP IEQUIV
  852.  
  853. * Pas d'option 'SUIT' => Fermeture du fichier
  854. IF (INOREW.EQ.0) CLOSE(UNIT=IOPER)
  855.  
  856. C ... Il n'y a pas de champ global, donc ...
  857.  
  858. RETURN
  859.  
  860. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  861. C ... Fin de la partie où tout se passe bien ...
  862. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  863.  
  864. 9999 CONTINUE
  865. MOTERR(1:8)='AVS '
  866. CALL ERREUR(705)
  867.  
  868. 10000 CONTINUE
  869. IF(NCCHPO.NE.0) THEN
  870. SEGSUP NCCHPO
  871. ENDIF
  872. IF(NCMCHA.NE.0) THEN
  873. SEGSUP NCMCHA
  874. ENDIF
  875. IF(VALCHP.NE.0) THEN
  876. SEGSUP VALCHP
  877. ENDIF
  878. IF(VALMCH.NE.0) THEN
  879. SEGSUP VALMCH
  880. ENDIF
  881. IF(IEQUIV.NE.0) THEN
  882. SEGSUP IEQUIV
  883. ENDIF
  884.  
  885. RETURN
  886.  
  887. 4000 FORMAT(5I11)
  888. 4010 FORMAT(I11,3(1X,1P,1E14.7))
  889. 4020 FORMAT(2I11,' pt',I11)
  890. 4030 FORMAT(13I11)
  891. 4040 FORMAT(1X,A4,',')
  892. 4041 FORMAT(1X,A8,',')
  893. C Modif DC 12/2006 - Sortie AVS compatible PARAVIEW
  894. 4042 FORMAT(1X,A4,',1 ')
  895. 4043 FORMAT(1X,A4,',1 1')
  896. C+ Fin modif
  897. 4050 FORMAT(I11,12(1X,1P,E14.7))
  898. END
  899.  
  900.  
  901.  
  902.  

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