Télécharger sorfer.eso

Retour à la liste

Numérotation des lignes :

  1. C SORFER SOURCE CB215821 19/08/20 21:22:06 10287
  2. C SORFER SOURCE KK2000 99/11/23 21:19:59 3715
  3. SUBROUTINE SORFER
  4.  
  5. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  6. C
  7. C But : Sortie d'un maillage et de CHPOINTs au format FER (ASCII)
  8. C
  9. C D'après : Michel Bulik (soravs)
  10. C : Stephane Gounand (sortcp)
  11. C Adaptations : Gregory TURBELIN
  12. C Octobre 1994 - Novembre 2002
  13. C
  14. C Appelé par : PRSORT
  15. C
  16. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  17.  
  18. PARAMETER(NBMCLE=3)
  19. CHARACTER*4 MTSCLE(NBMCLE)
  20.  
  21.  
  22. -INC PPARAM
  23. -INC CCOPTIO
  24. -INC SMCOORD
  25. -INC SMELEME
  26. -INC SMLCHPO
  27. -INC SMCHPOI
  28. -INC SMLMOTS
  29.  
  30. POINTEUR MAPOIN.MELEME, MAELEM.MELEME
  31. POINTEUR IPT10.MELEME, IPT11.MELEME
  32.  
  33. POINTEUR NCMCHA.MLMOTS, NCCHPO.MLMOTS
  34.  
  35.  
  36. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  37. C
  38. SEGMENT VALCHP
  39. REAL*8 RVACHP(NBCCHP,NBNMAP)
  40. END SEGMENT
  41. C
  42. C Segment : VALeurs du CHPoint
  43. C
  44. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  45.  
  46. SEGMENT IEQUIV
  47. INTEGER LEQUIV(IECART)
  48. END SEGMENT
  49.  
  50. SEGMENT VALV
  51. INTEGER IVALV(NBVALV)
  52. END SEGMENT
  53.  
  54. CHARACTER*8 MTYP
  55. CHARACTER*4 NOM4
  56.  
  57. C !! CHARACTER*n pour NUX NUY NUZ => JGN=n (dans MLMOTS)
  58. CHARACTER*6 NUX
  59. CHARACTER*6 NUY
  60. CHARACTER*6 NUZ
  61.  
  62. REAL*8 VALTEM
  63.  
  64. INTEGER NBCHPO
  65. LOGICAL SORMAI, SORCHP, EXISEL, CNDTN
  66. LOGICAL CMPINT
  67. EXTERNAL CMPINT
  68.  
  69. PARAMETER(LENTIT=40)
  70. CHARACTER*(LENTIT) TITHED
  71.  
  72. DATA MTSCLE/'TITR','SUIT','TEMP'/
  73.  
  74. C Initialisation du titre par défaut
  75. TITHED(1:LENTIT)='Sortie CAST3M -> FERView '
  76.  
  77. NCCHPO=0
  78. NCMCHA=0
  79. VALCHP=0
  80. IEQUIV=0
  81.  
  82. SORMAI=.FALSE.
  83. SORCHP=.FALSE.
  84.  
  85. C ... Recherche des objets à sortir ...
  86.  
  87. CALL LIROBJ('MAILLAGE',IVAL,0,IRETOU)
  88. IF(IRETOU.EQ.1) THEN
  89.  
  90. MELEME=IVAL
  91. SORMAI=.TRUE.
  92.  
  93. MAELEM=MELEME
  94. EXISEL=.TRUE.
  95.  
  96. MAPOIN=MAELEM
  97. CALL CHANGE(MAPOIN,1)
  98. C ... Attention ! MAPOIN est déjà actif (voir CHANGE) ...
  99.  
  100. ENDIF
  101.  
  102. C ... Initialisation de la pile
  103. N1 =0
  104. SEGINI MLCHPO
  105. IF(.NOT.SORMAI) THEN
  106. GOTO 9996
  107. ELSE
  108. 09 CONTINUE
  109. CALL LIROBJ('CHPOINT ',IVAL,0,IRETOU)
  110. IF(IRETOU.EQ.1) THEN
  111. ICHPOI(**)=IVAL
  112. GOTO 09
  113. ENDIF
  114.  
  115. NBCHPO=ICHPOI(/1)
  116. IF(NBCHPO.NE.0) THEN
  117. SORCHP=.TRUE.
  118. ENDIF
  119. ENDIF
  120.  
  121. C ... Lecture des mots clés éventuels ...
  122.  
  123. NBCGLO=0
  124. INOREW=0
  125. NENR=0
  126. NBSUIT=1
  127. NREW=1
  128. VALTEM=0.D0
  129.  
  130. 10 CALL LIRMOT(MTSCLE,NBMCLE,IRAN,0)
  131.  
  132. C 'TITR'
  133. IF (IRAN.EQ.1) THEN
  134. CALL LIRCHA(TITHED(1:LENTIT),1,LCHAR)
  135. IF (LCHAR.EQ.0) GOTO 9999
  136.  
  137. C 'SUIT'
  138. ELSEIF(IRAN.EQ.2) THEN
  139. INOREW=1
  140. CALL LIRENT(NBSUIT,0,IRETOU)
  141. IF(IRETOU.EQ.0) THEN
  142. NBSUIT = NBSUIT + 1
  143. ENDIF
  144.  
  145. C 'TEMP'
  146. ELSEIF(IRAN.EQ.3) THEN
  147. NBCGLO=1
  148. CALL LIRREE(VALTEM,1,IRETOU)
  149. IF(IRETOU.EQ.0) GOTO 9999
  150.  
  151. ENDIF
  152.  
  153. IF(IRAN.NE.0) GOTO 10
  154.  
  155. IF(INOREW.EQ.1.AND.VALTEM.EQ.0.D0) GOTO 9997
  156.  
  157. C ... NELMAI = Nombre d'ÉLéments du MAIllage ...
  158. IF(EXISEL) THEN
  159. CALL ECROBJ('MAILLAGE',MAELEM)
  160. CALL NBEL
  161. CALL LIRENT(NELMAI,1,IRETOU)
  162. IF(IERR.NE.0) GOTO 9999
  163. ELSE
  164. NELMAI=0
  165. ENDIF
  166.  
  167. C ... NBNMAP = NomBre de Noeuds du MAPoin ...
  168. CALL ECROBJ('MAILLAGE',MAPOIN)
  169. CALL NBNO
  170. CALL LIRENT(NBNMAP,1,IRETOU)
  171. IF(IERR.NE.0) GOTO 9999
  172.  
  173.  
  174. C ... Si le MAILLAGE et des CHPOINTs sont présents, on vérifiera que
  175. C le MAILLAGE et le support du CHPOINT ont une partie commune ...
  176.  
  177. IF(SORMAI.AND.SORCHP) THEN
  178.  
  179. DO 20 ICH=1,NBCHPO
  180. MCHPOI=ICHPOI(ICH)
  181.  
  182. C ... IPT3 = support du CHPOINT ...
  183. CALL ECRCHA('MAIL')
  184. CALL ECROBJ('CHPOINT ',MCHPOI)
  185. CALL EXTRAI
  186. CALL LIROBJ('MAILLAGE',IPT3,1,IRETOU)
  187. IF(IERR.NE.0) GOTO 9999
  188.  
  189. C ... NNSCHP = Nombre de Noeuds du Support du CHPoint ...
  190. CALL ECROBJ('MAILLAGE',IPT3)
  191. CALL NBNO
  192. CALL LIRENT(NNSCHP,1,IRETOU)
  193. IF(IERR.NE.0) GOTO 9999
  194.  
  195. C ... Pour les explications de cette partie voir la partie
  196. C équivalente dans SORTAVS.eso, au niveau du traitement du MCHAML ...
  197. IF(NBNMAP.EQ.NNSCHP) THEN
  198. SEGACT MAPOIN
  199. SEGACT IPT3
  200. NBEL1=MAPOIN.NUM(/2)
  201. NBEL2= IPT3.NUM(/2)
  202. IF(NBEL1.EQ.NBEL2 .AND. NBEL1.GT.0) THEN
  203. C ... Le cas où les deux maillages sont simples ...
  204. NBNN1=MAPOIN.NUM(/1)
  205. NBNN2= IPT3.NUM(/1)
  206. IF((NBNN1.EQ.NBNN2).AND.(MAPOIN.ITYPEL.EQ.IPT3.ITYPEL))
  207. & THEN
  208. ILONG=NBEL1*NBNN1
  209. CNDTN=CMPINT(MAPOIN.NUM(1,1),IPT3.NUM(1,1),ILONG)
  210. ELSE
  211. CNDTN=.FALSE.
  212. ENDIF
  213. ELSE IF(NBEL1.EQ.NBEL2 .AND. NBEL1.EQ.0) THEN
  214. C ... Le cas où les deux maillages sont composés ...
  215. NBS1=MAPOIN.LISOUS(/1)
  216. NBS2= IPT3.LISOUS(/1)
  217. IF(NBS1.EQ.NBS2) THEN
  218. CNDTN=.TRUE.
  219. DO 1200 I=1,NBS1
  220. IPT10=MAPOIN.LISOUS(I)
  221. IPT11= IPT3.LISOUS(I)
  222. SEGACT IPT10
  223. SEGACT IPT11
  224. IF((IPT10.NUM(/1).EQ.IPT11.NUM(/1)) .AND.
  225. & (IPT10.NUM(/2).EQ.IPT11.NUM(/2)) .AND.
  226. & (IPT10.ITYPEL .EQ.IPT11.ITYPEL) ) THEN
  227. ILONG=IPT10.NUM(/1)*IPT10.NUM(/2)
  228. CNDTN=CNDTN.AND.CMPINT(IPT10.NUM(1,1),
  229. & IPT11.NUM(1,1),ILONG)
  230. ELSE
  231. CNDTN=.FALSE.
  232. ENDIF
  233. 1200 CONTINUE
  234. ELSE
  235. CNDTN=.FALSE.
  236. ENDIF
  237. ELSE
  238. C ... Dans le cas où NBEL1 n'est pas egal à NBEL2 il est peu
  239. C probable quoique pas exclu que les deux maillages soient
  240. C égaux, on met donc CoNDiTioN à FAUX ...
  241. CNDTN=.FALSE.
  242. ENDIF
  243. ELSE
  244. CNDTN=.FALSE.
  245. ENDIF
  246.  
  247. IF(CNDTN) THEN
  248. NNDS=0
  249. ELSE
  250. C ... IPT4 = ici à la différence symétrique du MAPOIN et du support du CHPOINT ...
  251. CALL ECROBJ('MAILLAGE',MAPOIN)
  252. CALL ECROBJ('MAILLAGE',IPT3)
  253. CALL PRDIFF
  254. CALL LIROBJ('MAILLAGE',IPT4,1,IRETOU)
  255. IF(IERR.NE.0) GOTO 9999
  256.  
  257. CALL ECROBJ('MAILLAGE',IPT4)
  258. CALL NBNO
  259. CALL LIRENT(NNDS,1,IRETOU)
  260. IF(IERR.NE.0) GOTO 9999
  261. ENDIF
  262.  
  263. C ... IPT4 = intersection du MAPOIN et du support du CHPOINT ...
  264. IF(NNDS.EQ.NBNMAP+NNSCHP) THEN
  265. IPT4=0
  266. NBNIN4=0
  267. ELSE
  268. CALL ECROBJ('MAILLAGE',MAPOIN)
  269. CALL ECROBJ('MAILLAGE',IPT3)
  270. CALL INTERS
  271. CALL LIROBJ('MAILLAGE',IPT4,1,IRETOU)
  272. IF(IERR.NE.0) GOTO 9999
  273.  
  274. C ... NBNIN4 = NomBre de Noeuds de l'INtersection ipt4 ...
  275. CALL ECROBJ('MAILLAGE',IPT4)
  276. CALL NBNO
  277. CALL LIRENT(NBNIN4,1,IRETOU)
  278. IF(IERR.NE.0) GOTO 9999
  279. ENDIF
  280.  
  281. IF(NBNIN4.EQ.0) THEN
  282. C ... Quand NBNIN4=0 -> cas No 1 ...
  283. SORCHP=.FALSE.
  284. CALL ERREUR(-297)
  285. CALL ERREUR(-296)
  286. ELSE IF(NBNIN4.EQ.NBNMAP) THEN
  287. C ... Si NBNIN4=NBNMAP (cas 2), il faut réduire le CHPOINT sur le maillage ...
  288. CALL REDUIR(MCHPOI,MAPOIN,IRETOU)
  289. IF(IRETOU.EQ.0) THEN
  290. GOTO 9999
  291. ELSE
  292. ICHPOI(ICH)=IRETOU
  293. ENDIF
  294. ELSE IF (NBNIN4.EQ.NNSCHP) THEN
  295. C ... Cas No 4 - le support du CHPOINT est entièrement contenu dans le
  296. C maillage, donc on ne fait rien ...
  297. ELSE
  298. C ... Sinon, c'est le cas 3, il faut donc "aggrandir" le CHPOINT,
  299. C en fait on va le réduire sur l'intersection IPT4, ceci pour
  300. C éliminer les composantes dont le support est en dehors du maillage ...
  301. CALL REDUIR(MCHPOI,IPT4,IRETOU)
  302. IF(IRETOU.EQ.0) THEN
  303. GOTO 9999
  304. ELSE
  305. ICHPOI(ICH)=IRETOU
  306. ENDIF
  307. ENDIF
  308.  
  309. 20 CONTINUE
  310. ENDIF
  311.  
  312.  
  313. C ... Puisqu'on ne sort que certains noeuds il faut transformer les
  314. C connectivités, pour ceci on se servira du SEGMENT IEQUIV ...
  315.  
  316. C ... Recherche des numéros maxi et mini des noeuds dont on a besoin ...
  317.  
  318. SEGACT MAPOIN
  319. NBELEM=MAPOIN.NUM(/2)
  320. NBNN=MAPOIN.NUM(/1)
  321. IF(NBELEM.EQ.NBNMAP) THEN
  322.  
  323. IF(NBNN.NE.1) GOTO 9999
  324. IPTMIN=MAPOIN.NUM(1,1)
  325. IPTMAX=MAPOIN.NUM(1,1)
  326. DO 1500 I=1,NBELEM
  327. IF(MAPOIN.NUM(1,I).LT.IPTMIN) IPTMIN=MAPOIN.NUM(1,I)
  328. IF(MAPOIN.NUM(1,I).GT.IPTMAX) IPTMAX=MAPOIN.NUM(1,I)
  329. 1500 CONTINUE
  330.  
  331. ELSE IF(NBELEM.EQ.0) THEN
  332.  
  333. NBSOUS=MAPOIN.LISOUS(/1)
  334. DO 1505 I=1,NBSOUS
  335. IPT5=LISOUS(I)
  336. SEGACT IPT5
  337. NBNTMP=IPT5.NUM(/1)
  338. NBETMP=IPT5.NUM(/2)
  339. IF(NBNTMP.NE.1) GOTO 9999
  340. IF(I.EQ.1) THEN
  341. IPTMIN=IPT5.NUM(1,1)
  342. IPTMAX=IPT5.NUM(1,1)
  343. ENDIF
  344. DO 1506 J=1,NBETMP
  345. IF(IPT5.NUM(1,J).LT.IPTMIN) IPTMIN=IPT5.NUM(1,J)
  346. IF(IPT5.NUM(1,J).GT.IPTMAX) IPTMAX=IPT5.NUM(1,J)
  347. 1506 CONTINUE
  348. 1505 CONTINUE
  349.  
  350. ENDIF
  351.  
  352. C ... Initialisation du segment IEQUIV ...
  353.  
  354. IECART=IPTMAX-IPTMIN+1
  355. SEGINI IEQUIV
  356. C ... et son remplissage ...
  357.  
  358. IF(NBELEM.EQ.NBNMAP) THEN
  359.  
  360. DO 1510 I=1,NBELEM
  361. LEQUIV(MAPOIN.NUM(1,I)-IPTMIN+1)=I
  362. 1510 CONTINUE
  363.  
  364. ELSE IF(NBELEM.EQ.0) THEN
  365.  
  366. NBSOUS=MAPOIN.LISOUS(/1)
  367. K=0
  368. DO 1515 I=1,NBSOUS
  369. IPT5=LISOUS(I)
  370. SEGACT IPT5
  371. NBNTMP=IPT5.NUM(/1)
  372. NBETMP=IPT5.NUM(/2)
  373. IF(NBNTMP.NE.1) GOTO 9999
  374. DO 1516 J=1,NBETMP
  375. K=K+1
  376. C ... Ici je suppose que chaque point n'est représenté qu'une
  377. C seule fois dans MAPOIN. En conséquence, dans la ligne en dessous
  378. C je n'ai pas mis de test si LEQUIV(IPT5.NUM(1,J)-IPTMIN+1) est
  379. C différent de zéro ...
  380. LEQUIV(IPT5.NUM(1,J)-IPTMIN+1)=K
  381. 1516 CONTINUE
  382. 1515 CONTINUE
  383.  
  384. ENDIF
  385.  
  386.  
  387. C ... Préparation de la première ligne du fichier, on connaît déjà
  388. C les nombres de noeuds et d'éléments, il manque les nombres de composantes
  389. C de tous les CHPOINTs (s'ils sont présents) ...
  390.  
  391. NBVAR=0
  392. IF(SORCHP) THEN
  393. DO 30 ICH=1,NBCHPO
  394. MCHPOI=ICHPOI(ICH)
  395. NBCOMP=-1
  396. CALL QUEPOI(MCHPOI,MELEME,INDIC,NBCOMP,NOMTOT)
  397. IF(IERR.NE.0) GOTO 9999
  398. NBVAR=NBVAR+NBCOMP
  399. 30 CONTINUE
  400.  
  401. C ... Maintenant on va remplir des segments contenant toutes les valeurs
  402. C des CHPOINTs en un seul morceau ...
  403.  
  404. NBCCHP=NBVAR
  405. kk= 0
  406. SEGINI VALCHP
  407. cC .. Boucle sur tous les CHPOINTs
  408. DO 40 ICH=1,NBCHPO
  409. MCHPOI=ICHPOI(ICH)
  410. CALL EXTR11(MCHPOI,NCCHPO)
  411. SEGACT NCCHPO
  412. NCC=NCCHPO.MOTS(/2)
  413.  
  414. C ... Remplissage des valeurs du CHPOINT ...
  415.  
  416. DO 1700 I=1,NCC
  417. DO 1700 J=1,NBNMAP
  418. RVACHP(I+kk,J)=0.D0
  419. 1700 CONTINUE
  420.  
  421. SEGACT MCHPOI
  422. NSOUPO=IPCHP(/1)
  423. C ... IDECNP = DECalage des Numéros de Points ...
  424. C inutile IDECNP=0
  425. C ... Boucle sur les sous-zones du CHPOINT dont chacune est définie par ...
  426. DO 1710 I=1,NSOUPO
  427. C ... un segment MSOUPO ...
  428. C !!
  429. CDEBUG WRITE(IOIMP,*) 'Sous-zone No ',I
  430. MSOUPO=IPCHP(I)
  431. SEGACT MSOUPO
  432. NC=NOHARM(/1)
  433. C ... son support géométrique ...
  434. IPT7=IGEOC
  435. CALL NOMOBJ('MAILLAGE','MASUPCHP',IPT7)
  436. CALL ECROBJ('MAILLAGE',IPT7)
  437. CALL NBNO
  438. CALL LIRENT(NPOSCH,1,IRETOU)
  439. IF(IERR.NE.0) GOTO 9999
  440. SEGACT IPT7
  441. CDEBUG WRITE(IOIMP,*) ' -> ',NPOSCH,' noeuds'
  442. CDEBUG WRITE(IOIMP,*) 'IPT7 : ITYPEL = ',IPT7.ITYPEL
  443. CDEBUG WRITE(IOIMP,*) 'IPT7 : NBELEM = ',IPT7.NUM(/2)
  444. C ... et ses valeurs ...
  445. MPOVAL=IPOVAL
  446. SEGACT MPOVAL
  447. N=VPOCHA(/1)
  448. IF(N.NE.NPOSCH) THEN
  449. MOTERR(1:8)='CHPOINT '
  450. CALL ERREUR(708)
  451. GOTO 10000
  452. ENDIF
  453. C ... Boucle sur les composantes du CHPOINT ...
  454. DO 1720 J=1,NC
  455. C ... dont on cherche la place dans NCCHPO ...
  456. WRITE(NOM4,'(A4)') NOCOMP(J)
  457. DO 1730 K=1,NCC
  458. IF(NCCHPO.MOTS(K).EQ.NOM4) GOTO 1740
  459. 1730 CONTINUE
  460. 1740 CONTINUE
  461.  
  462. C ... Maintenant K pointe le NOCOMP(J) dans NCCHPO ...
  463. CDEBUG WRITE(IOIMP,*) 'Composante No',J,' correspond à K = ',K
  464. C ... Maintenant il faut parcourir les noeuds du support du CHPOINT ...
  465. C ... Si ce support est un maillage élémentaire, ceci est simple ...
  466. IF(IPT7.NUM(/2).GT.0) THEN
  467. CDEBUG WRITE(IOIMP,*) 'Support = Maillage élémentaire'
  468. DO 1750 L=1,N
  469. C ... ça ne marchera pas dans le cas général, car l'ordre des n'est pas
  470. C forcément le meme dans le MAPOIN et dans le support du CHPOINT ...
  471. C RVACHP(K+kk,L+IDECNP)=VPOCHA(L,J) ...
  472. C ... il faut chercher la position du noeud ...
  473. NNSCHP=IPT7.NUM(1,L)
  474. IF(NNSCHP.GE.IPTMIN.AND.NNSCHP.LE.IPTMAX) THEN
  475. NNMAPO=LEQUIV(NNSCHP-IPTMIN+1)
  476. ELSE
  477. NNMAPO=0
  478. ENDIF
  479. CDEBUG WRITE(IOIMP,*) 'Noeud ',L,' = ',NNSCHP,' -> NNMAPO = ',NNMAPO
  480. IF(NNMAPO.NE.0) RVACHP(K+kk,NNMAPO)=VPOCHA(L,J)
  481. 1750 CONTINUE
  482. C ... Sinon on va s'amuser ...
  483. ELSE
  484. CDEBUG WRITE(IOIMP,*) 'Support = Maillage composé'
  485. L=0
  486. NBSOUS=IPT7.LISOUS(/1)
  487. DO 1765 M=1,NBSOUS
  488. IPT8=IPT7.LISOUS(M)
  489. SEGACT IPT8
  490. NBELEM=IPT8.NUM(/2)
  491. CDEBUG WRITE(IOIMP,*) 'IPT8 : ITYPEL = ',IPT8.ITYPEL
  492. CDEBUG WRITE(IOIMP,*) 'IPT8 : NBELEM = ',NBELEM
  493. DO 1770 MM=1,NBELEM
  494. L=L+1
  495. NNSCHP=IPT8.NUM(1,MM)
  496. IF(NNSCHP.GE.IPTMIN.AND.NNSCHP.LE.IPTMAX) THEN
  497. NNMAPO=LEQUIV(NNSCHP-IPTMIN+1)
  498. ELSE
  499. NNMAPO=0
  500. ENDIF
  501. CDEBUG WRITE(IOIMP,*) 'Noeud ',L,' = ',NNSCHP,' -> NNMAPO = ',NNMAPO
  502. IF(NNMAPO.NE.0) RVACHP(K+kk,NNMAPO)=VPOCHA(L,J)
  503. 1770 CONTINUE
  504. 1765 CONTINUE
  505. ENDIF
  506. 1720 CONTINUE
  507. C inutile IDECNP=IDECNP+NPOSCH
  508. 1710 CONTINUE
  509. kk=kk+NCC
  510. IF(kk.GT.NBCCHP) GOTO 9999
  511. 40 CONTINUE
  512. ENDIF
  513.  
  514. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  515. C ... Sortie au format FER ...
  516. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  517.  
  518. C ... On écrase un éventuel contenu du fichier No IOPER ...
  519. IF(INOREW.EQ.0) THEN
  520. REWIND IOPER
  521.  
  522. C ... On écrit le titre
  523. CALL LENCHA(TITHED,LTH)
  524. WRITE(IOPER,4001) TITHED(1:LTH)
  525.  
  526. C ... Ligne de tete ...
  527. WRITE(IOPER,4000) NBNMAP,IDIM
  528.  
  529. C ... Les noeuds ...
  530. DO 2000 I=1,NBNMAP
  531. SEGACT MAPOIN
  532. NUMNO=MAPOIN.NUM(1,I)
  533. IF(IDIM.EQ.2) THEN
  534. WRITE(IOPER,4010) I,XCOOR((NUMNO-1)*(IDIM+1)+1),
  535. & XCOOR((NUMNO-1)*(IDIM+1)+2)
  536. ELSE
  537. WRITE(IOPER,4010) I,XCOOR((NUMNO-1)*(IDIM+1)+1),
  538. & XCOOR((NUMNO-1)*(IDIM+1)+2),
  539. & XCOOR((NUMNO-1)*(IDIM+1)+3)
  540. ENDIF
  541. 2000 CONTINUE
  542.  
  543. C ... Le maillage ...
  544. WRITE(IOPER,4000) NELMAI
  545. IDECAL=0
  546. IF(EXISEL) THEN
  547. SEGACT MAELEM
  548. NBELEM=MAELEM.NUM(/2)
  549. IF(NBELEM.GT.0) THEN
  550. CALL FERMEL(MAELEM,IDECAL,1,IEQUIV,IPTMIN)
  551. ELSE
  552. NBSOUS=MAELEM.LISOUS(/1)
  553. DO 2100 I=1,NBSOUS
  554. LESOUS=MAELEM.LISOUS(I)
  555. CALL FERMEL(LESOUS,IDECAL,I,IEQUIV,IPTMIN)
  556. 2100 CONTINUE
  557. ENDIF
  558. ENDIF
  559.  
  560. ENDIF
  561.  
  562. C ... Les CHPOINTs ...
  563. IF(SORCHP) THEN
  564.  
  565. C ... On commence par les noms des composantes ...
  566.  
  567. C Il faut récupérer les noms des variables
  568. JGN=6
  569. JGM=NBVAR
  570. JCPT=1
  571. SEGINI MLMOTS
  572. DO 60 INBCH=1,NBCHPO
  573. MCHPOI=ICHPOI(INBCH)
  574. SEGACT MCHPOI
  575. MSOUPO=IPCHP(1)
  576. SEGACT MSOUPO
  577. NC=NOCOMP(/2)
  578. DO 602 INC=1,NC
  579. MOTS(JCPT)(1:1)=' '
  580. LNC=LEN(NOCOMP(INC))
  581. DO 604 ILNC=1,LNC
  582. MOTS(JCPT)(ILNC+1:ILNC+1)=NOCOMP(INC)(ILNC:ILNC)
  583. 604 CONTINUE
  584. MOTS(JCPT)(LNC+2:LNC+2)=' '
  585. JCPT=JCPT+1
  586. 602 CONTINUE
  587. 60 CONTINUE
  588.  
  589. C ... Pour tracer les déformées, FERVIEW utilise les 3
  590. C ... premiers champs, il faut donc que se soient UX, UY, UZ
  591.  
  592. WRITE(NUX,'(A4)') ' UX '
  593. WRITE(NUY,'(A4)') ' UY '
  594. WRITE(NUZ,'(A4)') ' UZ '
  595.  
  596. C ... Boucles pour trouver les No de UX UY UZ respectivement
  597.  
  598. NBVALV=NBVAR
  599. SEGINI VALV
  600.  
  601. I=1
  602. DO 5030 J=1,NBVAR
  603. IF (MOTS(J).EQ.NUX) THEN
  604. IVALV(I) = J
  605. I=I+1
  606. ENDIF
  607. 5030 CONTINUE
  608.  
  609. DO 5040 J=1,NBVAR
  610. IF(MOTS(J).EQ.NUY) THEN
  611. IVALV(I) = J
  612. I=I+1
  613. ENDIF
  614. 5040 CONTINUE
  615.  
  616.  
  617. DO 5050 J=1,NBVAR
  618. IF(MOTS(J).EQ.NUZ) THEN
  619. IVALV(I) = J
  620. I=I+1
  621. ENDIF
  622. 5050 CONTINUE
  623.  
  624.  
  625. DO 5070 J=1,NBVAR
  626. IF((MOTS(J).NE.NUZ).AND.(MOTS(J).NE.NUY)
  627. & .AND.(MOTS(J).NE.NUX)) THEN
  628. IVALV(I) = J
  629. I=I+1
  630. ENDIF
  631. 5070 CONTINUE
  632.  
  633.  
  634. C ... IVALV(1,2,3 ...) contient respectivement les places de UX UY UZ ...
  635.  
  636. CDEBUG DO 5000 J=1,NBVAR
  637. CDEBUG WRITE(6,*) 'MOTS(J) =',MOTS(J)
  638. CDEBUG WRITE(6,*) 'MOTS(IVALV(J))=',MOTS(IVALV(J))
  639. CDEBUG 5000 CONTINUE
  640.  
  641. IF(INOREW.EQ.0) THEN
  642. WRITE(IOPER,4030) NBCCHP, ((MOTS(IVALV(I))),I=1,NBVAR)
  643. SEGSUP MLMOTS
  644. ENDIF
  645.  
  646. SEGSUP NCCHPO
  647.  
  648. C ... INFO SUR LE TPS
  649.  
  650. WRITE(IOPER,4020)NBSUIT,VALTEM
  651.  
  652. C ... Et ensuite leurs valeurs ...
  653. DO 2200 I=1,NBNMAP
  654. WRITE(IOPER,4050) I,(RVACHP((IVALV(K)),I),K=1,NBVAR)
  655. 2200 CONTINUE
  656. SEGSUP VALCHP
  657. SEGSUP VALV
  658. ENDIF
  659.  
  660.  
  661. C ... Le ménage ...
  662.  
  663. SEGSUP IEQUIV
  664. SEGSUP MLCHPO
  665. C ... Il n'y a pas de champ global, donc ...
  666.  
  667. RETURN
  668.  
  669. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  670. C ... Fin de la partie où tout se passe bien ...
  671. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  672.  
  673. 9996 CONTINUE
  674. WRITE(IOIMP,*)'Pas d''objet de type MAILLAGE spécifié'
  675. GOTO 9999
  676.  
  677. 9997 CONTINUE
  678. WRITE(IOIMP,*)'Pour l''instant, chaque enregistrement doit'
  679. WRITE(IOIMP,*)'être associé à un instant précis (mot clé TEMP)'
  680. GOTO 9999
  681.  
  682. 9999 CONTINUE
  683. WRITE(IOIMP,*)'An error was detected in subroutine sorfer'
  684. CALL ERREUR(223)
  685.  
  686. 10000 CONTINUE
  687. IF(NCCHPO.NE.0) THEN
  688. SEGSUP NCCHPO
  689. ENDIF
  690. IF(NCMCHA.NE.0) THEN
  691. SEGSUP NCMCHA
  692. ENDIF
  693. IF(VALCHP.NE.0) THEN
  694. SEGSUP VALCHP
  695. ENDIF
  696.  
  697. IF(IEQUIV.NE.0) THEN
  698. SEGSUP IEQUIV
  699. ENDIF
  700.  
  701. RETURN
  702.  
  703. 4000 FORMAT(2I6)
  704. 4001 FORMAT(A)
  705. 4010 FORMAT(I5,3(1X,1P,1E14.7))
  706. 4015 FORMAT (99(A,1X))
  707. 4020 FORMAT(I6,E14.7)
  708. 4030 FORMAT(I5,2X, 99A)
  709. 4050 FORMAT(I6,12(1X,1P,E14.7))
  710. END
  711.  
  712.  
  713.  

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