Télécharger raft.eso

Retour à la liste

Numérotation des lignes :

  1. C RAFT SOURCE BP208322 16/11/18 21:20:46 9177
  2. SUBROUTINE RAFT
  3. C **********************************************************************
  4. C INTERFACE CASTEM 2000
  5. C
  6. C SURF2 = RAFT (CHPO1) SURF1 ;
  7. C
  8. C
  9. C OBJET :
  10. C _______
  11. C
  12. C L'OPERATEUR RAFT RAFINE UN MAILLAGE TRIANGULAIRE (OBJET SURF1)
  13. C POUR RESPECTER UNE CARTE DE TAILLEW DONNEE (OBJET CHPO1). LES ELEM-
  14. C ENTS SONT DES TRIANGLES LINEAIRES QUELLES QUE SOIENT LES DIRECTIVES
  15. C D'OPTION.
  16. C
  17. C
  18. C DATE : 03.05.96 / 03.04.97
  19. C ______
  20. C
  21. C AUTEURS : O. STAB
  22. C _________
  23. C
  24. C
  25. C **********************************************************************
  26. IMPLICIT INTEGER(I-N)
  27. IMPLICIT REAL*8 (A-H,O-Z)
  28. C
  29. -INC CCOPTIO
  30. -INC SMELEME
  31. -INC SMCOORD
  32. -INC CCGEOME
  33. -INC SMCHPOI
  34. SEGMENT ITRAVX
  35. INTEGER ITVL (ITOTAI)
  36. ENDSEGMENT
  37. SEGMENT RTRAV
  38. REAL*8 RTVL ( ITOTAR)
  39. ENDSEGMENT
  40. SEGMENT ICPR (XCOOR(/1)/(IDIM+1))
  41. SEGMENT ICPP (XCOOR(/1)/(IDIM+1))
  42. SEGMENT IRADEC
  43. REAL*8 RADEC (MRIADEC)
  44. ENDSEGMENT
  45. C elimination de l'external TC
  46. C INTEGER D2CHPO
  47. C EXTERNAL D2CHPO
  48. INTEGER NRIADC,NITMAX,NRTMAX,NPONEW,IERRDS
  49. C --- VARIABLES INTERNES ---
  50. INTEGER NBN,NBE,IDIMC,NBNMAX,NBCMAX,IDE,NPOMAX,NBEMAX,ITRNOE
  51. INTEGER ITRTRI,NOETRI,ITRAV,IRTRAV,NITMX2,NRTMX2,ICOORD
  52. INTEGER I,NCC,NOEMAX
  53. C
  54. CALL DSINIT
  55. IERRDS = 0
  56. C =======================
  57. C --- 1.LECTURE DES DONNEES ---
  58. C =======================
  59. C
  60. * LECTURE DES OBJETS COURANTS (ENTREES)
  61. * =====================================
  62. IF(IDIM.NE.2) THEN
  63. INTERR(1)=IDIM
  64. C FONCTION INDISPONIBLE EN DIMENSION %I1
  65. CALL ERREUR(709)
  66. GOTO 999
  67. ENDIF
  68. C
  69. CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  70. IF(IERR.NE.0) THEN
  71. C ON A PAS TROUVE LE MAILLAGE
  72. CALL ERREUR(503)
  73. GOTO 999
  74. ENDIF
  75. C
  76. CALL LIRENT ( IVAL,0,IRETOU)
  77. C
  78. SEGACT IPT1
  79. NBE = IPT1.NUM(/2)
  80. NBEINI = NBE
  81. NBNTOT = -1
  82. IF(IRETOU.NE.0) THEN
  83. IF( IVAL.LT.NBE )THEN
  84. C Le nombre de noeuds ne peut ètre inférieur à %i1
  85. C (nombre d'éléments)
  86. INTERR(1) = NBE
  87. CALL ERREUR(838)
  88. SEGDES IPT1
  89. GOTO 999
  90. ENDIF
  91. NBNTOT = IVAL
  92. ENDIF
  93.  
  94. IF((IPT1.LISOUS(/1).NE.0).OR.
  95. > (IPT1.ITYPEL.NE.4))THEN
  96. C DONNEES INCOMPATIBLES
  97. CALL ERREUR(21)
  98. SEGDES IPT1
  99. GOTO 999
  100. ENDIF
  101. SEGDES IPT1
  102. *
  103. * LECTURE DU CHAMPS DE DENSITE
  104. * ============================
  105. *
  106. CALL LIROBJ('CHPOINT',MCHPO1,0,IRETOU)
  107. IF(IRETOU.EQ.0)THEN
  108. C ON A PAS TROUVE LE CHAMPS DE POINTS
  109. IF(IIMPI.NE.0) CALL ERREUR(839)
  110. PCHPOI = 0
  111. ELSE
  112. PCHPOI = 1
  113. ENDIF
  114. C
  115. C ---- VERIFICATION DU CHPOINT ----
  116. IF( PCHPOI.EQ.1)THEN
  117. SEGACT MCHPO1
  118. MSOUP1 = MCHPO1.IPCHP(1)
  119. SEGACT MSOUP1
  120. IF( MCHPO1.IPCHP(/1).GT.1)THEN
  121. C IL Y A PLUS D'UN CHAMP PAR POINT LEQUEL CHOISIR ?
  122. CALL ERREUR(840)
  123. SEGDES IPT1,MCHPO1,MSOUP1
  124. GOTO 999
  125. ENDIF
  126. C
  127. 8003 MPOVA1 = MSOUP1.IPOVAL
  128. SEGACT MPOVA1
  129. IF( MPOVA1.VPOCHA(/2).NE.1 )THEN
  130. C Il y a plus d'une valeur par point ?!
  131. CALL ERREUR(841)
  132. SEGDES IPT1,MCHPO1,MSOUP1,MPOVA1
  133. GOTO 999
  134. ENDIF
  135. SEGDES MCHPO1,MSOUP1,MPOVA1
  136. ENDIF
  137. C ---- FIN VERIFICATION DU CHPOINT ----
  138. *
  139. *
  140. * ALLOCATION DE LA MEMOIRE
  141. * =====================================
  142. *
  143. *
  144. *
  145. * =====================================
  146. IDIMC = IDIM
  147. NBNMAX = 3
  148. NBCMAX = NBNMAX
  149. NBADET = 50
  150. C
  151. ICMEMO = 1
  152. NBNINI = 0
  153. C
  154. C --- POUR TESTER LES MESSAGE D'ERREUR ET LA REALLOCATION :
  155. NBNREL = (10 * NBEINI ) / 2
  156. NBNABS = 40000
  157. 5 CONTINUE
  158. NBNREL = 7 * (NBEINI / 2)
  159. IF( NBNINI.NE.0 )NBNREL = 7 * NBNINI
  160. IF(NBNTOT.NE.-1) THEN
  161. NPOMAX = NBNTOT*ICMEMO + NBADET
  162. ELSE
  163. NPOMAX = MAX(NBNREL,NBNABS)*ICMEMO + NBADET
  164. ENDIF
  165. NBEMAX = MAX((14*NBEINI),(2*NBNABS)) * ICMEMO
  166. C
  167. 6 CONTINUE
  168. C
  169. C NITMAX = 20 * NPOMAX + 288 + 310
  170. C NRTMAX = 12 * (NPOMAX + 12)
  171. C
  172. NITMAX = (NBNMAX+NBCMAX)*NBEMAX +
  173. > NPOMAX +
  174. > MAX(7*NPOMAX , 6*NBADET+10) + 288
  175. C
  176. C ITRNOE,ITRTRI, NOETRI,ITRAV (MAX SMAOCR,R2RAF)
  177. C
  178. C
  179. NRTMAX = (IDIMC*NPOMAX) +
  180. > NBEMAX +
  181. > 2*NBEMAX +
  182. > (IDIMC*NBEMAX) +
  183. > (IDIMC*NPOMAX) + 224
  184. C
  185. C ICOORD, RADEC, ? , ITRAV (SPHERES+COORD)
  186. C
  187. C
  188. *
  189. * TRANSFERT DANS LA STRUCTURE DE L'ALGO
  190. * =====================================
  191. *
  192. ICOORD = 1
  193. ITRNOE = 1
  194. IDE = 2
  195. NCC = 1
  196. C --- INITIALISATION EN CAS DE REALLOCATION ---
  197. NBE = NBEINI
  198. *
  199. * REMPLISSAGE DU TABLEAU DE CONNEXION
  200. * ===================================
  201. SEGACT IPT1
  202. ITOTAI= NITMAX
  203. SEGINI ITRAVX
  204. NBANC = XCOOR(/1) /( IDIM+1)
  205. SEGINI,ICPR,ICPP
  206. ITOTAR = NRTMAX
  207. SEGINI RTRAV
  208. MRIADEC = NPOMAX
  209. SEGINI IRADEC
  210. INO = 0
  211. DO 7764 I=1,NBE
  212. DO 7764 J=1,NBNMAX
  213. IA = IPT1.NUM(J,I)
  214. IF( ICPR(IA).EQ.0 ) THEN
  215. INO = INO+1
  216. ICPR(IA) = INO
  217. ICPP(INO)= IA
  218. DO 7763 K=1,IDIMC
  219. RTVL((INO-1)*IDIMC+K+ICOORD-1)=
  220. > XCOOR((IA-1)*(IDIM+1)+K)
  221. 7763 CONTINUE
  222. C --- PAR DEFAUT : LA DENSITE PONCTUELLE ---
  223. RADEC(INO) = XCOOR(IA*(IDIM+1))
  224. ENDIF
  225. ITVL((I-1)*NBNMAX +J+ITRNOE-1) = ICPR(IA)
  226. 7764 CONTINUE
  227. NBN = INO
  228. NBNINI = INO
  229. SEGDES IPT1
  230. C
  231. C ON A LE NOMBRE EXACT DE NOEUDS DANS LE MAILLAGE
  232. C
  233. NPONEW=NPOMAX-NBN
  234. IF( NPONEW.LE.0 )THEN
  235. IF( NBNTOT.NE.-1)THEN
  236. C Le nombre de noeuds ne peut ètre inférieur à %i1
  237. C (nombre de noeuds existants)
  238. INTERR(1) = NBN
  239. CALL ERREUR(844)
  240. SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP
  241. GOTO 999
  242. ENDIF
  243. NPOMAX = 5 * NBN
  244. SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP
  245. C Patience on reprend avec plus de mémoire...
  246. CALL ERREUR(850)
  247. GOTO 6
  248. ENDIF
  249. *
  250. IF(PCHPOI.EQ.1)THEN
  251. *
  252. * TRANSFERT DE LA DENSITE
  253. * -----------------------
  254. SEGACT MCHPO1,MSOUP1,MPOVA1
  255. IF( MPOVA1.VPOCHA(/1).NE.NBN )THEN
  256. SEGDES MCHPO1,MSOUP1,MPOVA1
  257. SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP
  258. C La densité (CHPOINT) doit ètre définie sur LE maillage donné.
  259. CALL ERREUR(843)
  260. GOTO 999
  261. ENDIF
  262. * LECTURE DU MAILLAGE ASSOCIE AU CHPOINT
  263. IPT2 = MSOUP1.IGEOC
  264. SEGACT IPT2
  265. NBE2 = IPT2.NUM(/2)
  266. NBNN2 = IPT2.NUM(/1)
  267. C SEGINI IRADEC
  268. NRIADC = MPOVA1.VPOCHA(/1)
  269. *
  270. DO 8000 I=1,NRIADC
  271. * ------- LECTURE DE L'ANCIEN NUMERO ---------
  272. IA = IPT2.NUM(1,I)
  273. * ------- NOUVEAU NUMERO --------
  274. INO = ICPR(IA)
  275. IF((INO.LT.1).OR.(INO.GT.NRIADC))THEN
  276. SEGDES MCHPO1,MSOUP1,MPOVA1,IPT2
  277. SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP
  278. C La densité (CHPOINT) doit ètre définie sur LE maillage donné.
  279. CALL ERREUR(843)
  280. GOTO 999
  281. ENDIF
  282. RADEC(INO) = MPOVA1.VPOCHA(I,1)
  283. 8000 CONTINUE
  284. SEGDES MCHPO1,MSOUP1,MPOVA1,IPT2
  285. ELSE
  286. * --------------------------------------------------
  287. * PAS DE CHPOINT => ON VERIFIE QUE LA DENSITE DONNEE
  288. C PAR RADEC(INO) = XCOORD(IA,3) EST ACCEPTABLE
  289. * --------------------------------------------------
  290. NRIADC = NBNINI
  291. DO 8001 INO=1,NBNINI
  292. IF( RADEC(INO).LE.0 )GOTO 8002
  293. 8001 CONTINUE
  294. GOTO 8004
  295. 8002 NRIADC = 0
  296. 8004 CONTINUE
  297. ENDIF
  298. *
  299. C =======================
  300. C --- 1.1. ALLOCATION ---
  301. C =======================
  302. C
  303. C
  304. ITRTRI = ITRNOE + (NBEMAX * NBNMAX)
  305. NOETRI = ITRTRI + (NBEMAX * NBCMAX)
  306. ITRAV = NOETRI + NPOMAX
  307. NITMX2 = NITMAX - ITRAV
  308. IRTRAV = NPOMAX * IDIMC + 1
  309. NRTMX2 = NRTMAX - IRTRAV
  310. NOEMAX = NPOMAX
  311. C
  312. C =========================================
  313. C --- 2. CREATION DE LA STRUCTURE DE DONNEES ---
  314. C =========================================
  315. C
  316. *
  317. CALL SMAOCR(IDE,ITVL(ITRNOE),NBE,RTVL(ICOORD),
  318. > NBN,IDIMC,
  319. > ITVL(ITRNOE),NBNMAX,ITVL(ITRTRI),
  320. > NBCMAX,ITVL(NOETRI),NOEMAX,
  321. > ITVL(ITRAV),NITMX2,NCC,IERRDS)
  322. C
  323. IF( IERRDS.NE.0 )THEN
  324. IF( IERRDS.EQ.-2 )THEN
  325. SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP
  326. CALL ERREUR(850)
  327. ICMEMO = ICMEMO + 1
  328. IERRDS = 0
  329. GOTO 5
  330. ENDIF
  331. C Maillage incorrect ?!!!
  332. SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP
  333. CALL ERREUR(844)
  334. GOTO 999
  335. ENDIF
  336. C
  337. C ==================================
  338. C --- 3. GENERATION DES NOEUDS ET
  339. C INSERTION DANS LA TRIANGULATION ---
  340. C ==================================
  341. C
  342. NITMX2 = NITMAX - ITRAV
  343. IRTRAV = NPOMAX * IDIMC + 1
  344. NRTMX2 = NRTMAX - IRTRAV
  345. NOEMAX = NPOMAX
  346. C
  347. IF( NRIADC.EQ. 0 )THEN
  348. C ========================
  349. C --- RAFFINEMENT PAR DEFAUT ---
  350. C ========================
  351. *
  352. CALL R2RAF(ITVL(ITRNOE),NBNMAX,ITVL(ITRTRI),NBCMAX,
  353. > ITVL(NOETRI),NOEMAX,
  354. > RTVL(ICOORD),NBN,NBE,NPOMAX,NBEMAX,
  355. > ITVL(ITRAV),NITMX2,RTVL(IRTRAV),NRTMX2,
  356. > IERRDS)
  357. ELSE
  358. C ========================
  359. C --- RAFFINEMENT ITERATIF ---
  360. C ========================
  361. C
  362. CALL R2CPO(IADEC,RADEC,
  363. C CALL R2CPO(D2CHPO,IADEC,RADEC, modif TC
  364. > ITVL(ITRNOE),NBNMAX,
  365. > ITVL(ITRTRI),NBCMAX,
  366. > ITVL(NOETRI),NOEMAX,
  367. > RTVL(ICOORD),IDIMC,NBN,NBE,NPOMAX,NBEMAX,
  368. > ITVL(ITRAV),NITMX2,RTVL(IRTRAV),NRTMX2,
  369. > NBENEW,IERRDS)
  370. ENDIF
  371. C
  372. C
  373. IF(IERRDS.NE.0)THEN
  374. IF(IERRDS.EQ.-2)THEN
  375. IF(NBNTOT.EQ.-1)THEN
  376. C PAS DE LIMITATION SUR LES NOEUDS, LA MEMOIRE EVALUEE
  377. C EST INSUFFISANTE
  378. SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP
  379. ICMEMO = ICMEMO + 1
  380. C Patience on reprend avec plus de mémoire...
  381. CALL ERREUR(850)
  382. IERRDS = 0
  383. GOTO 5
  384. ENDIF
  385. C LIMITATION SUR LES NOEUDS DONNE PAR L'UTILISATEUR
  386. IERRDS = 0
  387. GOTO 40
  388. ENDIF
  389. C IERRDS = -1 ...
  390. CALL ERREUR(848)
  391. C ERREUR GENERATION DE MAILLAGE. IL EST NEANMOINS CREE POUR CONTROLE
  392. C CALL ERREUR(27)
  393. IERRDS = 0
  394. GOTO 40
  395. ENDIF
  396. C
  397. *
  398. * REMPLISSAGE NOUVEL OBJET MAILLAGE ET TABLEAU DES COORDONNEES
  399. * ============================================================
  400. 40 CONTINUE
  401. NBELEM=NBE
  402. NBNN=3
  403. NBREF=0
  404. NBSOUS=0
  405. SEGINI MELEME
  406. NBPTS = NBN-NBNINI+NBANC
  407. SEGADJ MCOORD
  408. DO 7781 I=1,NBN-NBNINI
  409. XCOOR((NBANC +I-1)*(IDIM+1) +1) = RTVL((NBNINI+I-1)*IDIMC+1)
  410. XCOOR((NBANC +I-1)*(IDIM+1) +2) = RTVL((NBNINI+I-1)*IDIMC+2)
  411. * ---- POUR LA DENSITE : DENSITE COURANTE ----
  412. XCOOR((NBANC +I-1)*(IDIM+1) +3) = DENSIT
  413. 7781 CONTINUE
  414. *
  415. DO 7782 I=1,NBE
  416. DO 7783 J=1,3
  417. IA=ITVL((I-1)*NBNMAX +J-1+ITRNOE)
  418. C
  419. IF ( IA .LE.NBNINI) THEN
  420. IB = ICPP(IA)
  421. ELSE
  422. IB = IA -NBNINI +NBANC
  423. ENDIF
  424. NUM(J,I)=IB
  425. 7783 CONTINUE
  426. ICOLOR(I) = IDCOUL
  427. 7782 CONTINUE
  428. ITYPEL=4
  429. SEGDES MELEME
  430. SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP
  431. CALL ECROBJ('MAILLAGE',MELEME)
  432. C
  433. C
  434. 999 END
  435.  
  436.  
  437.  
  438.  
  439.  
  440.  
  441.  
  442.  
  443.  
  444.  

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