Télécharger raft.eso

Retour à la liste

Numérotation des lignes :

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

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